Improve the handling of default methods

See the long Note [INLINE and default methods].  

This patch changes a couple of data types, with a knock-on effect on
the format of interface files.  A lot of files get touched, but is a
relatively minor change.  The main tiresome bit is the extra plumbing
to communicate default methods between the type checker and the
desugarer.

23 files changed, 290 insertions, 185 deletions

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index fa7ead0c8b..b151f5b3cb 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -58,7 +58,7 @@ module BasicTypes(
 	Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
-	isDefaultInlinePragma, isInlinePragma,
+	isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -597,6 +597,8 @@ data InlinePragma  	     -- Note [InlinePragma]
   = InlinePragma
       { inl_inline :: Bool           -- True <=> INLINE, 
       		      		     -- False <=> no pragma at all, or NOINLINE
+      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
+      		      	    	     --            explicit (non-type, non-dictionary) args
       , inl_act    :: Activation     -- Says during which phases inlining is allowed
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq )
@@ -664,14 +666,14 @@ isFunLike _            = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
-defaultInlinePragma 
-  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False }
-alwaysInlinePragma
-  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = True }
-neverInlinePragma   
-   = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False }
-dfunInlinePragma   
-   = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False }
+defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
+                                   , inl_rule = FunLike
+                                   , inl_inline = False
+                                   , inl_sat = Nothing }
+
+alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
+dfunInlinePragma   = defaultInlinePragma { inl_rule   = ConLike }
                                     
 
 isDefaultInlinePragma :: InlinePragma -> Bool
@@ -683,6 +685,9 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation
 isInlinePragma :: InlinePragma -> Bool
 isInlinePragma prag = inl_inline prag
 
+inlinePragmaSat :: InlinePragma -> Maybe Arity
+inlinePragmaSat = inl_sat
+
 inlinePragmaActivation :: InlinePragma -> Activation
 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
 
@@ -706,11 +711,14 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = ptext (sLit "FUNLIKE")
 
 instance Outputable InlinePragma where
-  ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info })
-    = pp_inline <+> pp_info <+> pp_activation
+  ppr (InlinePragma { inl_inline = inline, inl_act = activation
+                    , inl_rule = info, inl_sat = mb_arity })
+    = pp_inline <> pp_sat <+> pp_info <+> pp_activation
     where
       pp_inline | inline    = ptext (sLit "INLINE")
                 | otherwise = ptext (sLit "NOINLINE")
+      pp_sat | Just ar <- mb_arity = braces (int ar)
+             | otherwise           = empty
       pp_info | isFunLike info = empty
               | otherwise      = ppr info
       pp_activation 
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index b5525dcd73..16c45b7583 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -345,7 +345,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args)
+    wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index c98fc01671..83692a80a1 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -474,6 +474,7 @@ data UnfoldingGuidance
                 -- See Note [INLINE for small functions] in CoreUnfold
       ug_unsat_ok  :: Bool,	-- True <=> ok to inline even if unsaturated
       ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring
+      		-- So True,True means "always"
     }
 
   | UnfIfGoodArgs {	-- Arose from a normal Id; the info here is the
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index fc31d5a22a..7d041542ae 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -43,6 +43,7 @@ import PprCore		()	-- Instances
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
+import CoreArity       ( manifestArity )
 import CoreUtils
 import Id
 import DataCon
@@ -140,13 +141,17 @@ mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolde
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
-mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding
-mkInlineRule unsat_ok expr arity 
+mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding
+mkInlineRule expr mb_arity 
   = mkCoreUnfolding True InlineRule 	 -- Note [Top-level flag on inline rules]
     		    expr' arity 
 		    (UnfWhen unsat_ok boring_ok)
   where
     expr' = simpleOptExpr expr
+    (unsat_ok, arity) = case mb_arity of
+                          Nothing -> (unSaturatedOk, manifestArity expr')
+                          Just ar -> (needSaturated, ar)
+              
     boring_ok = case calcUnfoldingGuidance True    -- Treat as cheap
     	      	     			   False   -- But not bottoming
                                            (arity+1) expr' of
@@ -184,7 +189,6 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
       	        | uncondInline n_val_bndrs (iBox size)
                 , expr_is_cheap
       	        -> UnfWhen unSaturatedOk boringCxtOk   -- Note [INLINE for small functions]
-
 		| top_bot  -- See Note [Do not inline top-level bottoming functions]
 		-> UnfNever
 
@@ -626,9 +630,11 @@ actual arguments.
 \begin{code}
 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 couldBeSmallEnoughToInline threshold rhs 
-  = case calcUnfoldingGuidance False False threshold rhs of
-       (_, UnfNever) -> False
-       _             -> True
+  = case sizeExpr (iUnbox threshold) [] body of
+       TooBig -> False
+       _      -> True
+  where
+    (_, body) = collectBinders rhs
 
 ----------------
 smallEnoughToInline :: Unfolding -> Bool
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index f6fc5a38a0..9e29c96d36 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -142,12 +142,10 @@ dsHsBind _ rest
 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   = do	{ core_prs <- ds_lhs_binds NoSccs binds
 	; let env = mkABEnv exports
-	      ar_env = mkArityEnv binds
 	      do_one (lcl_id, rhs) 
 		| Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-		= WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )	  -- Not overloaded
-                  makeCorePair gbl_id (lookupArity ar_env lcl_id)
-		               (addAutoScc auto_scc gbl_id rhs)
+		= WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id spec_prags )	  -- Not overloaded
+                  makeCorePair gbl_id False 0 (addAutoScc auto_scc gbl_id rhs)
 
 		| otherwise = (lcl_id, rhs)
 
@@ -217,9 +215,7 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 		where
 		  fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 
-	      ar_env = mkArityEnv binds
 	      env = mkABEnv exports
-
 	      mk_lg_bind lcl_id gbl_id tyvars
 		 = NonRec (setIdInfo lcl_id vanillaIdInfo)
 				-- Nuke the IdInfo so that no old unfoldings
@@ -229,14 +225,14 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 
 	      do_one lg_binds (lcl_id, rhs) 
 		| Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-		= WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )	  -- Not overloaded
+		= WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id spec_prags )	  -- Not overloaded
                   (let rhs' = addAutoScc auto_scc gbl_id  $
 			      mkLams id_tvs $
 			      mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 			             | tv <- tyvars, not (tv `elem` id_tvs)] $
 		              add_lets lg_binds rhs
 		  in return (mk_lg_bind lcl_id gbl_id id_tvs,
-			     makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
+			     makeCorePair gbl_id False 0 rhs'))
 		| otherwise
 		= do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
 		     ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
@@ -254,25 +250,24 @@ dsHsBind auto_scc rest
   = ASSERT( all (`elem` tyvars) all_tyvars )
     do	{ core_prs <- ds_lhs_binds NoSccs binds
 
-	; let	-- Always treat the binds as recursive, because the typechecker
-	        -- makes rather mixed-up dictionary bindings
+	; let	-- Always treat the binds as recursive, because the 
+	        -- typechecker makes rather mixed-up dictionary bindings
 	        core_bind = Rec core_prs
-		inl_arity = lookupArity (mkArityEnv binds) local
     
 	; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global 
-				         local inl_arity core_bind prags
+				         local core_bind prags
 
 	; let   global'   = addIdSpecialisations global rules
 	        rhs       = addAutoScc auto_scc global $
 			    mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
-		main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs
+		main_bind = makeCorePair global' (isDefaultMethod prags)
+                                         (dictArity dicts) rhs 
     
 	; return (main_bind : spec_binds ++ rest) }
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = do	{ core_prs <- ds_lhs_binds NoSccs binds
 	; let env = mkABEnv exports
-	      ar_env = mkArityEnv binds
 	      do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
 			          = (lcl_id, addAutoScc auto_scc gbl_id rhs)
 				  | otherwise = (lcl_id,rhs)
@@ -297,7 +292,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 		     ; locals' <- newSysLocalsDs (map substitute local_tys)
 		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 		     ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local 
-					              (lookupArity ar_env local) core_bind 
+					              core_bind 
 				                      spec_prags
 		     ; let global' = addIdSpecialisations global rules
 	                   rhs = mkLams tyvars $ mkLams dicts $
@@ -317,50 +312,40 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 		    (concat export_binds_s ++ rest)) }
 
 ------------------------
-makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
-makeCorePair gbl_id arity rhs
-  | isInlinePragma (idInlinePragma gbl_id)
+makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
+makeCorePair gbl_id is_default_method dict_arity rhs
+  | is_default_method		      -- Default methods are *always* inlined
+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+
+  | not (isInlinePragma inline_prag)
+  = (gbl_id, rhs)
+
+  | Just arity <- inlinePragmaSat inline_prag
       	-- Add an Unfolding for an INLINE (but not for NOINLINE)
 	-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
-  = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity,
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)),
+    	    -- NB: The arity in the InlineRule takes account of the dictionaries
      etaExpand arity rhs)
+
   | otherwise
-  = (gbl_id, rhs)
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
+  where
+    inline_prag = idInlinePragma gbl_id
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
 
 ------------------------
-type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
+type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
 	-- Maps the "lcl_id" for an AbsBind to
 	-- its "gbl_id" and associated pragmas, if any
 
-mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv
+mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
 -- Takes the exports of a AbsBinds, and returns a mapping
 --	lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
-
-mkArityEnv :: LHsBinds Id -> IdEnv Arity
-	-- Maps a local to the arity of its definition
-mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
-
-lhsBindArity :: LHsBind Id -> IdEnv Arity
-lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) 
-  = unitVarEnv (unLoc id) (matchGroupArity ms)
-lhsBindArity (L _ (AbsBinds { abs_exports = exports
-                            , abs_dicts = dicts
-                            , abs_binds = binds })) 
-  = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) 
-             | (_, gbl, lcl, _) <- exports]
-  where	     -- See Note [Nested arities] 
-    ar_env = mkArityEnv binds
-    n_val_dicts = dictArity dicts	
-
-lhsBindArity _ = emptyVarEnv	-- PatBind/VarBind
-
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
-
-lookupArity :: IdEnv Arity -> Id -> Arity
-lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
 \end{code}
 
 Note [Eta-expanding INLINE things]
@@ -435,17 +420,19 @@ Note that
 \begin{code}
 ------------------------
 dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
-        -> Id -> Id -> Arity		-- Global, local, arity of local
-        -> CoreBind -> [LSpecPrag]
+        -> Id -> Id 	-- Global, local
+        -> CoreBind -> TcSpecPrags
         -> DsM ( [(Id,CoreExpr)] 	-- Binding for specialised Ids
 	       , [CoreRule] )		-- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
-dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
-  = do { pairs <- mapMaybeM spec_one prags
-       ; let (spec_binds_s, rules) = unzip pairs
-       ; return (concat spec_binds_s, rules) }
+dsSpecs all_tvs dicts tvs poly_id mono_id mono_bind prags
+  = case prags of
+      IsDefaultMethod      -> return ([], [])
+      SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
+                          ; let (spec_binds_s, rules) = unzip pairs
+                          ; return (concat spec_binds_s, rules) }
  where 
-    spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
     spec_one (L loc (SpecPrag spec_co spec_inl))
       = putSrcSpanDs loc $ 
         do { let poly_name = idName poly_id
@@ -475,8 +462,6 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
 	   	      -- Get the INLINE pragma from SPECIALISE declaration, or,
                       -- failing that, from the original Id
 
-              	 spec_id_arity = inl_arity + count isDictId bndrs
-
               	 extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
 	      	 	  	    | d <- varSetElems (exprFreeVars ds_spec_expr)
 	      	 	  	    , isDictId d]
@@ -488,7 +473,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
 	    			(mkVarApps (Var spec_id) bndrs)
 
                  spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body)
-                 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
+                 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
 	    ; return (Just (spec_pair : unf_pairs, rule))
 	    } } } }
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index fa57d41e45..034949fc45 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -207,7 +207,7 @@ dsFCall fn_id fcall = do
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule needSaturated wrap_rhs (length args)
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (Just (length args))
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 91d1b903f5..01af78b73c 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -399,7 +399,8 @@ cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
 cvtInlineSpec Nothing 
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
-  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline }
+  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
+                 , inl_inline = inline, inl_sat = Nothing }
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index ba3dbd68bf..f3648832f3 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -143,7 +143,7 @@ data HsBindLR idL idR
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
-	abs_exports :: [([TyVar], idL, idL, [LSpecPrag])],	-- (tvs, poly_id, mono_id, prags)
+	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)
 	abs_binds   :: LHsBinds idL		-- The dictionary bindings and typechecked user bindings
 						-- mixed up together; you can tell the dict bindings because
 						-- they are all VarBinds
@@ -292,7 +292,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
   where
     ppr_exp (tvs, gbl, lcl, prags)
 	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-	  	nest 2 (vcat (map (pprPrag gbl) prags))]
+	  	nest 2 (pprTcSpecPrags gbl prags)]
 \end{code}
 
 
@@ -471,15 +471,28 @@ data Sig name	-- Signatures and pragmas
 type LFixitySig name = Located (FixitySig name)
 data FixitySig name = FixitySig (Located name) Fixity 
 
--- A Prag conveys pragmas from the type checker to the desugarer
-type LSpecPrag = Located SpecPrag
-data SpecPrag 
+-- TsSpecPrags conveys pragmas from the type checker to the desugarer
+data TcSpecPrags 
+  = IsDefaultMethod	-- Super-specialised: a default method should 
+    			-- be macro-expanded at every call site
+  | SpecPrags [Located TcSpecPrag]
+
+data TcSpecPrag 
   = SpecPrag   
 	HsWrapper	-- An wrapper, that specialises the polymorphic function
 	InlinePragma 	-- Inlining spec for the specialised function
 
-instance Outputable SpecPrag where
-  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
+noSpecPrags :: TcSpecPrags
+noSpecPrags = SpecPrags []
+
+hasSpecPrags :: TcSpecPrags -> Bool
+hasSpecPrags (SpecPrags ps) = not (null ps)
+hasSpecPrags IsDefaultMethod = False
+
+isDefaultMethod :: TcSpecPrags -> Bool
+isDefaultMethod IsDefaultMethod = True
+isDefaultMethod (SpecPrags {})  = False
+
 \end{code}
 
 \begin{code}
@@ -600,7 +613,14 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p
     pp_inl | isDefaultInlinePragma inl = empty
            | otherwise = ppr inl
 
-pprPrag :: Outputable id => id -> LSpecPrag -> SDoc
-pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
+pprTcSpecPrags _   IsDefaultMethod = ptext (sLit "<default method>")
+pprTcSpecPrags gbl (SpecPrags ps)  = vcat (map (pprSpecPrag gbl) ps)
+
+pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
+pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+
+instance Outputable TcSpecPrag where
+  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
 \end{code}
 
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index beb39c00f1..2931ffa70a 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -600,16 +600,18 @@ instance Binary RuleMatchInfo where
                       else return FunLike
 
 instance Binary InlinePragma where
-    put_ bh (InlinePragma a b c) = do
+    put_ bh (InlinePragma a b c d) = do
             put_ bh a
             put_ bh b
             put_ bh c
+            put_ bh d
 
     get bh = do
            a <- get bh
            b <- get bh
            c <- get bh
-           return (InlinePragma a b c)
+           d <- get bh
+           return (InlinePragma a b c d)
 
 instance Binary StrictnessMark where
     put_ bh MarkedStrict    = putByte bh 0
@@ -1188,11 +1190,12 @@ instance Binary IfaceUnfolding where
     put_ bh (IfCoreUnfold e) = do
 	putByte bh 0
 	put_ bh e
-    put_ bh (IfInlineRule a b e) = do
+    put_ bh (IfInlineRule a b c d) = do
 	putByte bh 1
 	put_ bh a
 	put_ bh b
-	put_ bh e
+	put_ bh c
+	put_ bh d
     put_ bh (IfWrapper a n) = do
 	putByte bh 2
 	put_ bh a
@@ -1200,6 +1203,9 @@ instance Binary IfaceUnfolding where
     put_ bh (IfDFunUnfold as) = do
 	putByte bh 3
 	put_ bh as
+    put_ bh (IfCompulsory e) = do
+	putByte bh 4
+	put_ bh e
     get bh = do
 	h <- getByte bh
 	case h of
@@ -1207,13 +1213,16 @@ instance Binary IfaceUnfolding where
 		  return (IfCoreUnfold e)
 	  1 -> do a <- get bh
 		  b <- get bh
-		  e <- get bh
-		  return (IfInlineRule a b e)
+		  c <- get bh
+		  d <- get bh
+		  return (IfInlineRule a b c d)
 	  2 -> do a <- get bh
 		  n <- get bh
 		  return (IfWrapper a n)
-	  _ -> do as <- get bh
+	  3 -> do as <- get bh
 		  return (IfDFunUnfold as)
+	  _ -> do e <- get bh
+		  return (IfCompulsory e)
 
 instance Binary IfaceNote where
     put_ bh (IfaceSCC aa) = do
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 9485dc9453..1db78220b7 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -211,11 +211,16 @@ data IfaceInfoItem
 
 data IfaceUnfolding 
   = IfCoreUnfold IfaceExpr
+  | IfCompulsory IfaceExpr	-- Only used for default methods, in fact
+
   | IfInlineRule Arity 
                  Bool		-- OK to inline even if *un*-saturated
+		 Bool		-- OK to inline even if context is boring
                  IfaceExpr 
+
   | IfWrapper    Arity Name	  -- NB: we need a Name (not just OccName) because the worker
 				  --     can simplify to a function in another module.
+
   | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
@@ -676,10 +681,11 @@ instance Outputable IfaceInfoItem where
   ppr HsNoCafRefs	 = ptext (sLit "HasNoCafRefs")
 
 instance Outputable IfaceUnfolding where
+  ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
   ppr (IfCoreUnfold e)     = parens (ppr e)
-  ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:")
-                             <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) 
-      		      	     <+> parens (ppr e)
+  ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule")
+                                  <+> ppr (a,uok,bok) 
+      		      	          <+> parens (ppr e)
   ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns)
 
@@ -799,10 +805,11 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)     = freeNamesIfExpr e
-freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper _ v)      = unitNameSet v
-freeNamesIfUnfold (IfDFunUnfold vs)    = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
+freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)	  = unitNameSet v
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 1c34edca3c..702a744d34 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1503,20 +1503,21 @@ toIfaceIdInfo id_info
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-                                , uf_src = src, uf_guidance = guidance })
-  = case src of
-	InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w)))
-	InlineRule {}   -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs)))
-        _other          -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
+toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+                                    , uf_src = src, uf_guidance = guidance })
+  = Just $ HsUnfold lb $
+    case src of
+	InlineRule {}
+          -> case guidance of
+               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
+               _other                     -> pprPanic "toIfUnfolding" (ppr unf)
+	InlineWrapper w  -> IfWrapper arity (idName w)
+        InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
+        InlineRhs        -> IfCoreUnfold (toIfaceExpr rhs)
 	-- Yes, even if guidance is UnfNever, expose the unfolding
 	-- If we didn't want to expose the unfolding, TidyPgm would
 	-- have stuck in NoUnfolding.  For supercompilation we want 
 	-- to see that unfolding!
-  where
-    sat = case guidance of
-            UnfWhen unsat_ok _ -> unsat_ok
-            _other             -> needSaturated
 
 toIfUnfolding lb (DFunUnfolding _con ops)
   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index c9c33dbde6..7d0d02ee12 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1015,11 +1015,19 @@ tcUnfolding name _ info (IfCoreUnfold if_expr)
     		     Just sig -> isBottomingSig sig
  		     Nothing  -> False
 
-tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr)
+tcUnfolding name _ _ (IfCompulsory if_expr)
   = do 	{ mb_expr <- tcPragExpr name if_expr
 	; return (case mb_expr of
 		    Nothing   -> NoUnfolding
-		    Just expr -> mkInlineRule unsat_ok expr arity) }
+		    Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do 	{ mb_expr <- tcPragExpr name if_expr
+	; return (case mb_expr of
+		    Nothing   -> NoUnfolding
+		    Just expr -> mkCoreUnfolding True InlineRule expr arity 
+                                                 (UnfWhen unsat_ok boring_ok))
+    }
 
 tcUnfolding name ty info (IfWrapper arity wkr)
   = do 	{ mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 300d88620e..2700c6fe54 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -977,6 +977,7 @@ mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
 -- The Maybe is because the user can omit the activation spec (and usually does)
 mkInlinePragma mb_act match_info inl 
   = InlinePragma { inl_inline = inl
+                 , inl_sat    = Nothing
                  , inl_act    = act
                  , inl_rule   = match_info }
   where
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2001a17dcd..a5a581b90e 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1982,7 +1982,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
 	      	      DataAlt dc -> setIdUnfolding case_bndr unf
 		      	  where
 			     	 -- See Note [Case binders and join points]
-		      	     unf = mkInlineRule needSaturated rhs 0
+		      	     unf = mkInlineRule rhs Nothing
 		      	     rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
 			     	   	        ++ varsToCoreExprs bndrs')
 
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 43425343f0..5c29ffbae4 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -915,10 +915,15 @@ specDefn subst body_uds fn rhs
 
 		-- Add an InlineRule if the parent has one
 		-- See Note [Inline specialisations]
-		final_spec_f | Just sat <- fn_has_inline_rule
-			     = spec_f_w_arity `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
-			     | otherwise 
-			     = spec_f_w_arity
+		final_spec_f 
+                  | Just sat <- fn_has_inline_rule
+		  = let 
+                       mb_spec_arity = if sat then Just spec_arity else Nothing
+                    in 
+                    spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+		  | otherwise 
+		  = spec_f_w_arity
+
 	   ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
       where
 	my_zipEqual xs ys zs
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 2547978590..b0759b92aa 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -274,8 +274,8 @@ checkSize fn_id rhs thing_inside
 
   | otherwise = thing_inside
   where
-    unfolding = idUnfolding fn_id
-    inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding)
+    unfolding   = idUnfolding fn_id
+    inline_rule = mkInlineRule rhs Nothing
 
 ---------------------
 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
@@ -314,15 +314,16 @@ splitFun fn_id fn_info wrap_dmds res_info rhs
 
 	wrap_rhs  = wrap_fn work_id
 	wrap_prag = InlinePragma { inl_inline = True
+                                 , inl_sat    = Nothing
                                  , inl_act    = ActiveAfter 0
                                  , inl_rule   = rule_match_info }
+		-- See Note [Wrapper activation]
+		-- The RuleMatchInfo is (and must be) unaffected
+		-- The inl_inline is bound to be False, else we would not be
+		--    making a wrapper
 
 	wrap_id   = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
 			  `setInlinePragma` wrap_prag
-			 	-- See Note [Wrapper activation]
-				-- The RuleMatchInfo is (and must be) unaffected
-				-- The inl_inline is bound to be False, else we would not be
-				--    making a wrapper
 		          `setIdOccInfo` NoOccInfo
 			        -- Zap any loop-breaker-ness, to avoid bleating from Lint
 				-- about a loop breaker with an INLINE rule
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index f21bbe609d..2871f3bd58 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -149,7 +149,7 @@ tcValBinds _ (ValBindsIn binds _) _
 
 tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
   = do  {       -- Typecheck the signature
-        ; let { prag_fn = mkPragFun sigs
+        ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
               ; ty_sigs = filter isTypeLSig sigs
               ; sig_fn  = mkTcSigFun ty_sigs }
 
@@ -336,9 +336,13 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
   ; if is_strict then
     do  { extendLIEs lie_req
         ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
-              mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
-              mk_export (_,    Just sig, mono_id) _       = ([], sig_id sig,             mono_id, [])
-                        -- ToDo: prags for unlifted bindings
+              mk_export (name, mb_sig,  mono_id) mono_ty 
+                = ([], the_id, mono_id, noSpecPrags)
+                              -- ToDo: prags for unlifted bindings
+	      	where
+                  the_id = case mb_sig of
+                             Just sig -> sig_id sig
+                             Nothing  -> mkLocalId name mono_ty
 
         ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds',
                    [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
@@ -372,7 +376,7 @@ mkExport :: TopLevelFlag -> RecFlag
 	    		 -- a tuple, so INLINE pragmas won't work
          -> TcPragFun -> [TyVar] -> [TcType]
          -> MonoBindInfo
-         -> TcM ([TyVar], Id, Id, [LSpecPrag])
+         -> TcM ([TyVar], Id, Id, TcSpecPrags)
 -- mkExport generates exports with 
 --      zonked type variables, 
 --      zonked poly_ids
@@ -395,7 +399,7 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
                                             poly_id (prag_fn poly_name)
                 -- tcPrags requires a zonked poly_id
 
-        ; return (tvs, poly_id', mono_id, spec_prags) }
+        ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
   where
     poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
 
@@ -410,22 +414,41 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
 ------------------------
 type TcPragFun = Name -> [LSig Name]
 
-mkPragFun :: [LSig Name] -> TcPragFun
-mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
-        where
-          prs = [(expectJust "mkPragFun" (sigName sig), sig) 
-                | sig <- sigs, isPragLSig sig]
-          env = foldl add emptyNameEnv prs
-          add env (n,p) = extendNameEnv_Acc (:) singleton env n p
+mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun
+mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
+  where
+    prs = mapCatMaybes get_sig sigs
+
+    get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
+    get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
+    get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
+    get_sig _                         = Nothing
+
+    add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
+      | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+      | otherwise                         = inl_prag
+
+    prag_env :: NameEnv [LSig Name]
+    prag_env = foldl add emptyNameEnv prs
+    add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
+
+    -- ar_env maps a local to the arity of its definition
+    ar_env :: NameEnv Arity
+    ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+  = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env	-- PatBind/VarBind
 
 tcPrags :: RecFlag
 	-> Bool     -- True <=> AbsBinds binds more than one variable
         -> Bool     -- True <=> function is overloaded
         -> Id -> [LSig Name]
-        -> TcM (Id, [LSpecPrag])
+        -> TcM (Id, [Located TcSpecPrag])
 -- Add INLINE and SPECLIASE pragmas
---    INLINE prags are added to the Id directly
---    SPECIALISE prags are passed to the desugarer via [LSpecPrag]
+--    INLINE prags are added to the (polymorphic) Id directly
+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
 tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs
@@ -491,7 +514,7 @@ warnPrags id bad_sigs herald
     ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
 
 --------------
-tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag
+tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag
 tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) 
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName poly_id
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 23ee423667..2d113b7bb5 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -179,7 +179,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 	; let
 	      (tyvars, _, _, op_items) = classBigSig clas
 	      rigid_info  = ClsSkol clas
-	      prag_fn	  = mkPragFun sigs
+	      prag_fn	  = mkPragFun sigs default_binds
 	      sig_fn	  = mkTcSigFun sigs
 	      clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
@@ -234,16 +234,20 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
         ; (dm_id_w_inline, spec_prags) 
                 <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
 
+        ; warnTc (not (null spec_prags))
+                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                  <+> quotes (ppr sel_name))
+
         ; tcInstanceMethodBody (instLoc this_dict) 
                                tyvars [this_dict]
                                ([], emptyBag)
                                dm_id_w_inline local_dm_id
-                               dm_sig_fn spec_prags meth_bind }
+                               dm_sig_fn IsDefaultMethod meth_bind }
 
 ---------------
 tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
 		     -> ([Inst], LHsBinds Id) -> Id -> Id
-          	     -> TcSigFun -> [LSpecPrag] -> LHsBind Name 
+          	     -> TcSigFun -> TcSpecPrags -> LHsBind Name 
           	     -> TcM (Id, LHsBind Id)
 tcInstanceMethodBody inst_loc tyvars dfun_dicts
 		     (this_dict, this_bind) meth_id local_meth_id
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index ee6de3357b..e46ab45eb4 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -363,8 +363,12 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
     zonkExport env (tyvars, global, local, prags)
 	-- The tyvars are already zonked
 	= zonkIdBndr env global			`thenM` \ new_global ->
-	  mapM zonk_prag prags			`thenM` \ new_prags -> 
+	  zonk_prags prags			`thenM` \ new_prags -> 
 	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
+
+    zonk_prags IsDefaultMethod = return IsDefaultMethod
+    zonk_prags (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') }
+
     zonk_prag (L loc (SpecPrag co_fn inl))
 	= do { (_, co_fn') <- zonkCoFn env co_fn
 	     ; return (L loc (SpecPrag co_fn' inl)) }
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 1af025e355..c4c5d586b4 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -33,8 +33,6 @@ import DataCon
 import Class
 import Var
 import CoreUnfold ( mkDFunUnfolding )
--- import CoreUtils  ( mkPiTypes )
-import PrelNames  ( inlineIdName )
 import Id
 import MkId
 import Name
@@ -667,7 +665,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
 
         ; return (unitBag $ noLoc $
                   AbsBinds inst_tvs' (map instToVar dfun_dicts)
-                            [(inst_tvs', dfun_id, instToId this_dict, [])]
+                            [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)]
                             (dict_bind `consBag` sc_binds)) }
   where
       -----------------------
@@ -753,7 +751,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
        ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
 
         -- Typecheck the methods
-       ; let prag_fn = mkPragFun uprags 
+       ; let prag_fn = mkPragFun uprags monobinds
              tc_meth = tcInstanceMethod loc standalone_deriv
                                         clas inst_tyvars'
 	     	       	 		dfun_dicts inst_tys'
@@ -801,7 +799,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
              main_bind = AbsBinds
                          inst_tyvars'
                          dfun_lam_vars
-                         [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
+                         [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)]
                          (unitBag dict_bind)
 
        ; showLIE (text "instance")
@@ -891,7 +889,7 @@ tcSuperClass inst_loc tyvars dicts (this_dict, this_bind)
 	     sc_id      = instToVar sc_dict
 	     sc_op_bind = AbsBinds tyvars 
 			     (map instToVar dicts) 
-                             [(tyvars, sc_op_id, sc_id, [])]
+                             [(tyvars, sc_op_id, sc_id, noSpecPrags)]
                              (this_bind `unionBags` sc_binds)
 
        ; return (sc_op_id, noLoc sc_op_bind) }
@@ -948,7 +946,7 @@ SpecPrag which, as it turns out, can be used unchanged for each method.
 The "it turns out" bit is delicate, but it works fine!
 
 \begin{code}
-tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName dfun_id
@@ -981,7 +979,7 @@ tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
 	 	 -> [TcType]
 		 -> (Inst, LHsBinds Id)  -- "This" and its binding
           	 -> TcPragFun	    	 -- Local prags
-		 -> [LSpecPrag]		 -- Arising from 'SPECLALISE instance'
+		 -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance'
                  -> LHsBinds Name 
 	  	 -> (Id, DefMeth)
           	 -> TcM (Id, LHsBind Id)
@@ -1006,13 +1004,13 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
 	      tc_body rn_bind 
                 = add_meth_ctxt rn_bind $
                   do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True 
-                                                    meth_id (prag_fn sel_name)
+                                                         meth_id (prag_fn sel_name)
                      ; tcInstanceMethodBody (instLoc this_dict)
                                     tyvars dfun_dicts
 				    ([this_dict], this_dict_bind)
                                     meth_id1 local_meth_id
 				    meth_sig_fn 
-                                    (spec_inst_prags ++ spec_prags) 
+                                    (SpecPrags (spec_inst_prags ++ spec_prags))
                                     rn_bind }
 
     	    --------------
@@ -1040,14 +1038,9 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
 		       dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
 					-- Might not be imported, but will be an OrigName
 		     ; dm_id <- tcLookupId dm_name
-		     ; inline_id <- tcLookupId inlineIdName
                      ; let dm_inline_prag = idInlinePragma dm_id
-                           dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
-			            HsVar dm_id 
-                           rhs | isInlinePragma dm_inline_prag  -- See Note [INLINE and default methods]
-                               = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
-                                       (L loc dm_app)
-                               | otherwise = dm_app
+                           rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
+			         HsVar dm_id 
 
 		           meth_bind = L loc $ VarBind { var_id = local_meth_id
                                                        , var_rhs = L loc rhs 
@@ -1057,8 +1050,8 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
 				    -- method to this version. Note [INLINE and default methods]
 				    
                            bind = AbsBinds { abs_tvs = tyvars, abs_dicts =  dfun_lam_vars
-                                           , abs_exports = [( tyvars, meth_id1
-                                                            , local_meth_id, spec_inst_prags)]
+                                           , abs_exports = [( tyvars, meth_id1, local_meth_id
+                                                            , SpecPrags spec_inst_prags)]
                                            , abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
 		     -- Default methods in an instance declaration can't have their own 
 		     -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
@@ -1143,7 +1136,8 @@ From the class decl we get
    $dmfoo :: forall v x. Baz v x => x -> x
    $dmfoo y = <blah>
 
-Notice that the type is ambiguous.  That's fine, though. The instance decl generates
+Notice that the type is ambiguous.  That's fine, though. The instance
+decl generates
 
    $dBazIntInt = MkBaz fooIntInt
    fooIntInt = $dmfoo Int Int $dBazIntInt
@@ -1155,8 +1149,9 @@ less work to generate the translated version!
 
 Note [INLINE and default methods]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We *copy* any INLINE pragma from the default method to the instance.
-Example:
+Default methods need special case.  They are supposed to behave rather like
+macros.  For exmample
+
   class Foo a where
     op1, op2 :: Bool -> a -> a
 
@@ -1164,31 +1159,57 @@ Example:
     op1 b x = op2 (not b) x
 
   instance Foo Int where
+    -- op1 via default method
     op2 b x = <blah>
+   
+The instance declaration should behave
+
+   just as if 'op1' had been defined with the
+   code, and INLINE pragma, from its original
+   definition. 
+
+That is, just as if you'd written
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+So for the above example we generate:
 
-Then we generate:
 
   {-# INLINE $dmop1 #-}
+  -- $dmop1 has an InlineCompulsory unfolding
   $dmop1 d b x = op2 d (not b) x
 
   $fFooInt = MkD $cop1 $cop2
 
   {-# INLINE $cop1 #-}
-  $cop1 = inline $dmop1 $fFooInt
+  $cop1 = $dmop1 $fFooInt
 
   $cop2 = <blah>
 
-Note carefully:
-  a) We copy $dmop1's inline pragma to $cop1.  Otherwise 
-     we'll just inline the former in the latter and stop, which 
-     isn't what the user expected
-
-  b) We use the magic 'inline' Id to ensure that $dmop1 really is
-     inlined in $cop1, even though 
-       (i)  the latter itself has an INLINE pragma
-       (ii) $dmop1 is not saturated
-     That is important to allow the mutual recursion between $fooInt and
-     $cop1 to be broken
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+  instance $cop1.  Otherwise we'll just inline the former in the
+  latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an 
+  unfolding with an InlineCompulsory source. That means
+  that it'll be inlined at every use site, notably in
+  each instance declaration, such as $cop1.  This inlining
+  must happen even though 
+    a) $dmop1 is not saturated in $cop1
+    b) $cop1 itself has an INLINE pragma
+
+  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+  recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+  (which makes the Unfoldings), we use the IsDefaultMethod constructor
+  in TcSpecPrags.
 
 
 %************************************************************************
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index f31ecd8b8b..83fd5124b2 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -789,7 +789,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
 
           raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineRule needSaturated body arity
+                              mkInlineRule body (Just arity)
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
@@ -830,7 +830,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
           let body = mkLams (tvs ++ args) expr
           raw_var <- newExportedVar (method_name name) (exprType body)
           let var = raw_var
-                      `setIdUnfolding` mkInlineRule needSaturated body (length args)
+                      `setIdUnfolding` mkInlineRule body (Just (length args))
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 8dccd61c24..c62c40546b 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -38,7 +38,7 @@ import Var
 import MkId               ( unwrapFamInstScrut )
 import Id                 ( setIdUnfolding )
 import TysWiredIn
-import BasicTypes         ( Boxity(..) )
+import BasicTypes         ( Boxity(..), Arity )
 import Literal            ( Literal, mkMachInt )
 
 import Outputable
@@ -348,7 +348,7 @@ polyVApply expr tys
       return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 
 
-data Inline = Inline Int -- arity
+data Inline = Inline Arity
             | DontInline
 
 addInlineArity :: Inline -> Int -> Inline
@@ -371,7 +371,7 @@ hoistExpr fs expr inl
   where
     mk_inline var = case inl of
                       Inline arity -> var `setIdUnfolding`
-                                      mkInlineRule needSaturated expr arity
+                                      mkInlineRule expr (Just arity)
                       DontInline   -> var
 
 hoistVExpr :: VExpr -> Inline -> VM VVar
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index cc91e9fc9c..c53c638a1c 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -106,7 +106,7 @@ vectTopBinder var inline expr
       return var'
   where
     unfolding = case inline of
-                  Inline arity -> mkInlineRule needSaturated expr arity
+                  Inline arity -> mkInlineRule expr (Just arity)
                   DontInline   -> noUnfolding
 
 vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr)