Do not inherit "SPECIALISE instance" for INLINE default methods

Nor should we generate specialised dfuns;
see Note [SPECIALISE instance pragmas]

1 files changed, 21 insertions, 16 deletions

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index ac9769ca25..2bf6164a31 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -716,7 +716,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
-       ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
+       ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds
 
         -- Typecheck the methods
        ; (meth_ids, meth_binds)
@@ -725,7 +725,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                 -- Those tyvars are inside the dfun_id's type, which is a bit
                 -- bizarre, but OK so long as you realise it!
               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
-                                inst_tys spec_info
+                                inst_tys spec_inst_info
                                 op_items ibinds
 
        -- Create the result bindings
@@ -776,7 +776,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                          map Var           meth_ids
 
              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
-                          , abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags }
+                          , abe_mono = self_dict, abe_prags = noSpecPrags }
+                          -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas]
              main_bind = AbsBinds { abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
@@ -895,16 +896,12 @@ Consider
      range (x,y) = ...
 
 We do *not* want to make a specialised version of the dictionary
-function.  Rather, we want specialised versions of each method.
+function.  Rather, we want specialised versions of each *method*.
 Thus we should generate something like this:
 
-  $dfIx :: (Ix a, Ix x) => Ix (a,b)
-  {- DFUN [$crange, ...] -}
-  $dfIx da db = Ix ($crange da db) (...other methods...)
-
-  $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
+  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
   {- DFUN [$crangePair, ...] -}
-  $dfIxPair = Ix ($crangePair da db) (...other methods...)
+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
 
   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
@@ -1067,14 +1064,22 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
         -- Adapt the SPECIALISE pragmas to work for this method Id
         -- There are two sources:
-        --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
-        --     These ones have the dfun inside, but [perhaps surprisingly]
-        --     the correct wrapper
         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
+        --     These ones have the dfun inside, but [perhaps surprisingly]
+        --     the correct wrapper.
     mk_meth_spec_prags meth_id spec_prags_for_me
-      = SpecPrags (spec_prags_for_me ++
-                   [ L loc (SpecPrag meth_id wrap inl)
-                   | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
+      = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
+      where
+        spec_prags_from_inst
+           | isInlinePragma (idInlinePragma meth_id)
+           = []  -- Do not inherit SPECIALISE from the instance if the
+                 -- method is marked INLINE, because then it'll be inlined
+                 -- and the specialisation would do nothing. (Indeed it'll provoke
+                 -- a warning from the desugarer
+           | otherwise 
+           = [ L loc (SpecPrag meth_id wrap inl)
+             | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]
 
     loc    = getSrcSpan dfun_id
     sig_fn = mkSigFun sigs