Commit d153e402 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Add the unfolding and inline-pragma for DFuns in DsBinds, not TcInstDcls

This is a straight refactoring that puts the generation of unfolding
info in one place, which is a lot tidier
parent 72517987
......@@ -51,6 +51,7 @@ import Class
import DataCon ( dataConWorkId )
import Name
import MkId ( seqId )
import IdInfo ( IdDetails(..) )
import Var
import VarSet
import Rules
......@@ -214,6 +215,9 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
| is_default_method -- Default methods are *always* inlined
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
| DFunId _ is_newtype <- idDetails gbl_id
= (mk_dfun_w_stuff is_newtype, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
EmptyInlineSpec -> (gbl_id, rhs)
......@@ -237,6 +241,22 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
(gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
-- See Note [ClassOp/DFun selection] in TcInstDcls
-- See Note [Single-method classes] in TcInstDcls
mk_dfun_w_stuff is_newtype
| is_newtype
= gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args
`setInlinePragma` dfunInlinePragma
(dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs)
(dfun_con, dfun_args) = collectArgs dfun_body
dfun_constr | Var id <- dfun_con
, DataConWorkId con <- idDetails id
= con
| otherwise = pprPanic "makeCorePair: dfun" (ppr rhs)
dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
......
......@@ -43,10 +43,7 @@ import Class
import Var
import VarEnv
import VarSet
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName,
genericClassNames )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, genericClassNames )
import Bag
import BasicTypes
import DynFlags
......@@ -883,26 +880,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
(dfun_id_w_fun, dfun_spec_prags)
| isNewTyCon class_tc
= ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
, SpecPrags [] ) -- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
dfun_spec_prags
| isNewTyCon class_tc = SpecPrags []
-- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
| otherwise
= ( dfun_id `setIdUnfolding` mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars)
dict_constr dfun_args
`setInlinePragma` dfunInlinePragma
, SpecPrags spec_inst_prags )
dfun_args :: [CoreExpr]
dfun_args = map Type inst_tys ++
map Var sc_ev_vars ++
map mk_meth_app meth_ids
mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars
export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
= SpecPrags spec_inst_prags
export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id
, abe_mono = self_dict, abe_prags = dfun_spec_prags }
-- NB: see Note [SPECIALISE instance pragmas]
main_bind = AbsBinds { abs_tvs = inst_tyvars
......
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