diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-29 15:36:28 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-31 09:08:43 +0000 |
commit | e741075ee27bceee696dde9647b1c102850af5b6 (patch) | |
tree | 0119bf990b129249652df6b266dcb9be57644d58 | |
parent | 68d3377644a25b0428d09a1135e5b30bb0a32fbd (diff) | |
download | haskell-e741075ee27bceee696dde9647b1c102850af5b6.tar.gz |
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
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 20 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 31 |
2 files changed, 28 insertions, 23 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 8c2541c3b6..a3aac1b5a3 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index a471e11732..f135fe5fb7 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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 |