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.

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 

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 $

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

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

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))
 	    } } } }

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}

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

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}
 

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

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

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)))

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)

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

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')
 

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

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

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])