[commit: ghc] master: Add the unfolding and inline-pragma for DFuns in DsBinds, not TcInstDcls (d153e40)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d153e4020e5e7c07bbe616381a97c760509ad3fa/ghc

>---------------------------------------------------------------

commit d153e4020e5e7c07bbe616381a97c760509ad3fa
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Oct 29 15:36:28 2014 +0000

    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


>---------------------------------------------------------------

d153e4020e5e7c07bbe616381a97c760509ad3fa
 compiler/deSugar/DsBinds.lhs      | 20 ++++++++++++++++++++
 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 8c2541c..a3aac1b 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 a471e11..f135fe5 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