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

5 files changed, 52 insertions, 33 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5bd31a7900..1c281927a9 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index de309d55e9..de27b94e9f 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -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))
 
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index 9b4e2d911c..e7a86e5004 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -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{}]}
 
diff --git a/testsuite/tests/simplCore/should_compile/T11742.hs b/testsuite/tests/simplCore/should_compile/T11742.hs
new file mode 100644
index 0000000000..e0a7333c57
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T11742.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Strict #-}
+
+module Foo where
+
+data Foo = Foo
+
+instance Eq Foo where
+  (==) Foo Foo = True
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 52cdea756d..9d88237b66 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -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'])