Make the new ClassOp/DFun selection mechanism work for single-method classes

I'd forgotten the case of single-method classes! I've also improved
the documentation. See
  Note [ClassOp/DFun selection]
  Note [Single-method classes]
both in TcInstDcls

2 files changed, 98 insertions, 26 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 98425f149a..6d8df877a9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -457,17 +457,25 @@ mkDictSelId no_unf name clas
         -- But it's type must expose the representation of the dictionary
         -- to get (say)         C a -> (a -> a)
 
-    info = noCafIdInfo
-                `setArityInfo`          1
+    base_info = noCafIdInfo
+                `setArityInfo`      1
                 `setAllStrictnessInfo`  Just strict_sig
-		`setSpecInfo`       mkSpecInfo [rule]
-		`setInlinePragInfo` neverInlinePragma
                 `setUnfoldingInfo`  (if no_unf then noUnfolding
-				       else mkImplicitUnfolding rhs)
-	-- Experimental: NOINLINE, so that their rule matches
-
-        -- We no longer use 'must-inline' on record selectors.  They'll
-        -- inline like crazy if they scrutinise a constructor
+				     else mkImplicitUnfolding rhs)
+		   -- In module where class op is defined, we must add
+		   -- the unfolding, even though it'll never be inlined
+		   -- becuase we use that to generate a top-level binding
+		   -- for the ClassOp
+
+    info | new_tycon = base_info  
+    	   	         -- For newtype dictionaries, just inline the class op
+                         -- See Note [Single-method classes] in TcInstDcls
+         | otherwise = base_info
+	 		`setSpecInfo`       mkSpecInfo [rule]
+			`setInlinePragInfo` neverInlinePragma
+			-- Otherwise add a magic BuiltinRule, and never inline it
+			-- so that the rule is always available to fire.
+			-- See Note [ClassOp/DFun selection] in TcInstDcls
 
     n_ty_args = length tyvars
 
@@ -484,11 +492,12 @@ mkDictSelId no_unf name clas
         -- It's worth giving one, so that absence info etc is generated
         -- even if the selector isn't inlined
     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
-    arg_dmd | isNewTyCon tycon = evalDmd
-            | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
-                                            | id <- arg_ids ])
+    arg_dmd | new_tycon = evalDmd
+            | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+                                     | id <- arg_ids ])
 
     tycon      = classTyCon clas
+    new_tycon  = isNewTyCon tycon
     [data_con] = tyConDataCons tycon
     tyvars     = dataConUnivTyVars data_con
     arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
@@ -497,8 +506,8 @@ mkDictSelId no_unf name clas
     the_arg_id = arg_ids !! index
 
     pred       = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id    = mkTemplateLocal     1 $ mkPredTy pred
-    (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
+    dict_id    = mkTemplateLocal 1 $ mkPredTy pred
+    (eq_ids,n) = mkCoVarLocals   2 $ mkPredTys eq_theta
     arg_ids    = mkTemplateLocalsNum n arg_tys
 
     mkCoVarLocals i []     = ([],i)
@@ -507,9 +516,9 @@ mkDictSelId no_unf name clas
                              in (y:ys,j)
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
-    rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
-             | otherwise        = Case (Var dict_id) dict_id (idType the_arg_id)
-                                       [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+    rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
+             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
+                                [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
 
 dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr
 -- Oh, very clever
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 96e63aa01e..c7fc8ab56f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -122,13 +122,8 @@ Running example:
 	{-# RULE "op1@C[a]" forall a, d:C a. 
                             op1 [a] (df_i d) = op1_i a d #-}
 
-* We want to inline the dictionary function itself as vigorously as we
-  possibly can, so that we expose that dictionary constructor to
-  selectors as much as poss.  We don't actually inline it; rather, we
-  use a Builtin RULE for the ClassOps (see MkId.mkDictSelId) to short
-  circuit such applications.  But the RULE only applies if it can "see"
-  the dfun's DFunUnfolding. 
-
+Note [Instances and loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Note that df_i may be mutually recursive with both op1_i and op2_i.
   It's crucial that df_i is not chosen as the loop breaker, even 
   though op1_i has a (user-specified) INLINE pragma.
@@ -146,6 +141,70 @@ Running example:
   a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
   unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
 
+Note [ClassOp/DFun selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One thing we see a lot is stuff like
+    op2 (df d1 d2)
+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
+'op2' and 'df' to get
+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
+       MkD _ op2 _ _ _ -> op2
+And that will reduce to ($cop2 d1 d2) which is what we wanted.
+
+But it's tricky to make this work in practice, because it requires us to 
+inline both 'op2' and 'df'.  But neither is keen to inline without having
+seen the other's result; and it's very easy to get code bloat (from the 
+big intermediate) if you inline a bit too much.
+
+Instead we use a cunning trick.
+ * We arrange that 'df' and 'op2' NEVER inline.  
+
+ * We arrange that 'df' is ALWAYS defined in the sylised form
+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
+
+ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
+   that lists its methods.
+
+ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
+   a suitable constructor application -- inlining df "on the fly" as it 
+   were.
+
+ * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
+   iff its argument satisfies exprIsConApp_maybe.  This is done in
+   MkId mkDictSelId
+
+ * We make 'df' CONLIKE, so that shared uses stil match; eg
+      let d = df d1 d2
+      in ...(op2 d)...(op1 d)...
+
+Note [Single-method classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the class has just one method (or, more accurately, just one elemen
+of {superclasses + methods}), then we want a different strategy. 
+
+   class C a where op :: a -> a
+   instance C a => C [a] where op = <blah>
+
+We translate the class decl into a newtype, which just gives
+a top-level axiom:
+
+   axiom Co:C a :: C a ~ (a->a)
+
+   op :: forall a. C a -> (a -> a)
+   op a d = d |> (Co:C a)
+
+   df :: forall a. C a => C [a]
+   {-# INLINE df #-}
+   df = $cop_list |> (forall a. C a -> (sym (Co:C a))
+
+   $cop_list :: forall a. C a => a -> a
+   $cop_list = <blah>
+
+So the ClassOp is just a cast; and so is the dictionary function.
+(The latter doesn't even have any lambdas.)  We can inline both freely.
+No need for fancy BuiltIn rules.  Indeed the BuiltinRule stuff does
+not work well for newtypes because it uses exprIsConApp_maybe.
+
 
 Note [Subtle interaction of recursion and overlap]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -710,8 +769,12 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
  	     mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
 	     arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
 
-             dfun_id_w_fun = dfun_id 
-                             `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+             dfun_id_w_fun | isNewTyCon (classTyCon clas) 
+                           = dfun_id   -- Just let the dfun inline; see Note [Single-method classes]
+                           | otherwise 
+                           = dfun_id   -- Do not inline; instead give it a magic DFunFunfolding
+			     	       -- See Note [ClassOp/DFun selection]
+                             `setIdUnfolding`  mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
                              `setInlinePragma` dfunInlinePragma
 
              main_bind = noLoc $ AbsBinds