Commit db9e4eb4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Move DFunUnfolding generation to TcInstDcls

The desugarer had a fragile case to generate the Unfolding for a
DFun. This patch moves the unfolding generation to TcInstDcls, where
all the pieces are to hand.

Fixes Trac #11742
parent 7d5ff3d3
......@@ -49,7 +49,6 @@ import Id
import MkId(proxyHashId)
import Class
import Name
import IdInfo ( IdDetails(..) )
import VarSet
import Rules
import VarEnv
......@@ -350,9 +349,6 @@ 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)
......@@ -376,23 +372,6 @@ 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
dictArity dicts = count isId dicts
......
......@@ -33,7 +33,9 @@ import TcDeriv
import TcEnv
import TcHsType
import TcUnify
import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams )
import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import CoreUnfold ( mkInlineUnfolding, mkDFunUnfolding )
import Type
import TcEvidence
import TyCon
......@@ -847,8 +849,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- con_app_tys = MkD ty1 ty2
-- con_app_scs = MkD ty1 ty2 sc1 sc2
-- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
con_app_tys = wrapId (mkWpTyApps inst_tys)
(dataConWrapId dict_constr)
con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr)
-- NB: We *can* have covars in inst_tys, in the case of
-- promoted GADT constructors.
......@@ -860,17 +861,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
inst_tv_tys = mkTyVarTys inst_tyvars
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
-- Do not inline the dfun; instead give it a magic DFunFunfolding
is_newtype = isNewTyCon class_tc
dfun_id_w_prags = addDFunPrags dfun_id dict_constr is_newtype
inst_tyvars dfun_ev_vars inst_tys sc_meth_ids
dfun_spec_prags
| isNewTyCon class_tc = SpecPrags []
| is_newtype = SpecPrags []
| otherwise = SpecPrags spec_inst_prags
-- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
| otherwise
= SpecPrags spec_inst_prags
export = ABE { abe_wrap = idHsWrapper
, abe_poly = dfun_id
, abe_mono = self_dict, abe_prags = dfun_spec_prags }
, abe_poly = dfun_id_w_prags
, abe_mono = self_dict
, abe_prags = dfun_spec_prags }
-- NB: see Note [SPECIALISE instance pragmas]
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
......@@ -884,6 +887,29 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
addDFunPrags :: DFunId -> DataCon -> Bool
-> [TyVar] -> [Id] -> [Type]
-> [Id] -> DFunId
-- DFuns need a special Unfolding and InlinePrag
-- See Note [ClassOp/DFun selection]
-- and Note [Single-method classes]
-- It's easiest to create those unfoldings right here, where
-- have all the pieces in hand, even though we are messing with
-- Core at this point, which the typechecker doesn't usually do
addDFunPrags dfun_id dict_con is_newtype dfun_tvs dfun_evs inst_tys sc_meth_ids
| is_newtype
= dfun_id `setIdUnfolding` mkInlineUnfolding (Just 0) con_app
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
`setInlinePragma` dfunInlinePragma
where
dfun_bndrs = dfun_tvs ++ dfun_evs
dict_args = map Type inst_tys ++
[mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
con_app = mkLams dfun_bndrs $
mkApps (Var (dataConWrapId dict_con)) dict_args
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))
......
......@@ -62,16 +62,21 @@ T8958.$trModule
AbsBinds [a] []
{Exports: [T8958.$fRepresentationala <= $dRepresentational
wrap: <>]
Exported types: T8958.$fRepresentationala
Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE]
:: forall a. Representational a
[LclIdX[DFunId], Str=DmdType]
[LclIdX[DFunId],
Str=DmdType,
Unf=DFun: \ (@ a[ssk]) -> T8958.C:Representational TYPE: a[ssk]]
Binds: $dRepresentational = T8958.C:Representational @ a
Evidence: [EvBinds{}]}
AbsBinds [a] []
{Exports: [T8958.$fNominala <= $dNominal
wrap: <>]
Exported types: T8958.$fNominala :: forall a. Nominal a
[LclIdX[DFunId], Str=DmdType]
Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE]
:: forall a. Nominal a
[LclIdX[DFunId],
Str=DmdType,
Unf=DFun: \ (@ a[ssk]) -> T8958.C:Nominal TYPE: a[ssk]]
Binds: $dNominal = T8958.C:Nominal @ a
Evidence: [EvBinds{}]}
{-# LANGUAGE Strict #-}
module Foo where
data Foo = Foo
instance Eq Foo where
(==) Foo Foo = True
......@@ -230,3 +230,4 @@ test('T11155',
['$MAKE -s --no-print-directory T11155'])
test('T11232', normal, compile, ['-O2'])
test('T11562', normal, compile, ['-O2'])
test('T11742', normal, compile, ['-O2'])
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