--------------------------------------
Attach inline pragmas to class methods
--------------------------------------
This fix makes INLINE pragmas on method bindings (in class
or instance decls) work properly.
It seems to have been hanging around in my tree for some time.
To be on the safe side, let's not merge this into 5.04.1, although
it should be fine (an an improvement).
getClassDeclSysNames, placeHolderType
)
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
getClassDeclSysNames, placeHolderType
)
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
-import RnHsSyn ( RenamedTyClDecl,
+import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
)
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
)
import TyCon ( tyConGenInfo )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
import TyCon ( tyConGenInfo )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
-import Id ( Id, idType, idName, setIdLocalExported )
+import Id ( Id, idType, idName, setIdLocalExported, setInlinePragma )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
-import NameSet ( emptyNameSet )
+import NameSet ( emptyNameSet, unitNameSet )
import Outputable
import Var ( TyVar )
import CmdLineOpts
import Outputable
import Var ( TyVar )
import CmdLineOpts
mkMethodBind origin clas inst_tys binds_in op_item `thenTc` \ (dm_inst, meth_info) ->
tcMethodBind xtve clas_tyvars theta
mkMethodBind origin clas inst_tys binds_in op_item `thenTc` \ (dm_inst, meth_info) ->
tcMethodBind xtve clas_tyvars theta
- [this_dict] meth_info `thenTc` \ (defm_bind, insts_needed) ->
+ [this_dict] prags meth_info `thenTc` \ (defm_bind, insts_needed) ->
tcAddErrCtxt (defltMethCtxt clas) $
tcAddErrCtxt (defltMethCtxt clas) $
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
-- from the method body
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
-- from the method body
+ -> [RenamedSig] -- Pragmas (e.g. inline pragmas)
-> (Id, TcSigInfo, RenamedMonoBinds) -- Details of this method
-> TcM (TcMonoBinds, LIE)
-> (Id, TcSigInfo, RenamedMonoBinds) -- Details of this method
-> TcM (TcMonoBinds, LIE)
-tcMethodBind xtve inst_tyvars inst_theta avail_insts
+tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
(sel_id, meth_sig, meth_bind)
=
-- Check the bindings; first adding inst_tyvars to the envt
(sel_id, meth_sig, meth_bind)
=
-- Check the bindings; first adding inst_tyvars to the envt
checkSigTyVars all_tyvars `thenTc` \ all_tyvars' ->
let
checkSigTyVars all_tyvars `thenTc` \ all_tyvars' ->
let
+ -- Attach inline pragmas as appropriate
+ (final_meth_id, inlines)
+ | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+ = (meth_id `setInlinePragma` phase,
+ if inl then unitNameSet (idName meth_id) else emptyNameSet)
+ | otherwise
+ = (meth_id, emptyNameSet)
+
+ is_inline (InlineSig _ name _ _) = name == idName sel_id
+ is_inline other = False
+
meth_tvs' = take (length meth_tvs) all_tyvars'
poly_meth_bind = AbsBinds meth_tvs'
(map instToId meth_dicts)
meth_tvs' = take (length meth_tvs) all_tyvars'
poly_meth_bind = AbsBinds meth_tvs'
(map instToId meth_dicts)
- [(meth_tvs', meth_id, local_meth_id)]
- emptyNameSet -- Inlines?
+ [(meth_tvs', final_meth_id, local_meth_id)]
+ inlines
(lie_binds `andMonoBinds` meth_bind)
in
returnTc (poly_meth_bind, lie)
(lie_binds `andMonoBinds` meth_bind)
in
returnTc (poly_meth_bind, lie)
sc_dicts ++ meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
sc_dicts ++ meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
- tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts
+ tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts uprags
in
mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->
in
mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->