Implement INLINABLE pragma

Implements Trac #4299.  Documentation to come.

compiler/basicTypes/BasicTypes.lhs

@@ -62,8 +62,10 @@ module BasicTypes(
 	CompilerPhase, 
 	Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
-        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
-	isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
+        InlineSpec(..), 
+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
+        neverInlinePragma, dfunInlinePragma, 
+	isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -645,12 +647,12 @@ data Activation = NeverActive
 
 data RuleMatchInfo = ConLike 			-- See Note [CONLIKE pragma]
                    | FunLike
-                   deriving( Eq, Data, Typeable )
+                   deriving( Eq, Data, Typeable, Show )
+	-- Show needed for Lexer.x
 
 data InlinePragma  	     -- Note [InlinePragma]
   = InlinePragma
-      { inl_inline :: Bool           -- True <=> INLINE, 
-      		      		     -- False <=> no pragma at all, or NOINLINE
+      { inl_inline :: InlineSpec
 
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
       		      	    	     --            explicit (non-type, non-dictionary) args
@@ -663,6 +665,14 @@ data InlinePragma  	     -- Note [InlinePragma]
 
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq, Data, Typeable )
+
+data InlineSpec   -- What the user's INLINE pragama looked like
+  = Inline
+  | Inlinable
+  | NoInline
+  | EmptyInlineSpec
+  deriving( Eq, Data, Typeable, Show )
+	-- Show needed for Lexer.x
 \end{code}
 
 Note [InlinePragma]
@@ -725,16 +735,24 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _            = False
 
+isInlineSpec :: InlineSpec -> Bool
+isInlineSpec Inline    = True
+isInlineSpec Inlinable = True
+isInlineSpec _         = False
+
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
                                    , inl_rule = FunLike
-                                   , inl_inline = False
+                                   , inl_inline = EmptyInlineSpec
                                    , inl_sat = Nothing }
 
-alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
 
+inlinePragmaSpec :: InlinePragma -> InlineSpec
+inlinePragmaSpec = inl_inline
+
 -- A DFun has an always-active inline activation so that 
 -- exprIsConApp_maybe can "see" its unfolding
 -- (However, its actual Unfolding is a DFunUnfolding, which is
@@ -746,10 +764,10 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = not inline && isAlwaysActive activation && isFunLike match_info
+  = isInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
-isInlinePragma prag = inl_inline prag
+isInlinePragma prag = isInlineSpec (inl_inline prag)
 
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
@@ -776,16 +794,20 @@ instance Outputable RuleMatchInfo where
    ppr ConLike = ptext (sLit "CONLIKE")
    ppr FunLike = ptext (sLit "FUNLIKE")
 
+instance Outputable InlineSpec where
+   ppr Inline          = ptext (sLit "INLINE")
+   ppr NoInline        = ptext (sLit "NOINLINE")
+   ppr Inlinable       = ptext (sLit "INLINABLE")
+   ppr EmptyInlineSpec = empty
+
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation
                     , inl_rule = info, inl_sat = mb_arity })
-    = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info 
+    = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info 
     where
-      pp_inl_act (False, AlwaysActive)  = empty	-- defaultInlinePragma
-      pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
-      pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
-      pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
-      pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
+      pp_act Inline   AlwaysActive = empty	
+      pp_act NoInline NeverActive  = empty
+      pp_act _        act          = ppr act
 
       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
              | otherwise           = empty

compiler/basicTypes/MkId.lhs

@@ -317,7 +317,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 wrap_rhs (Just (length dict_args + length id_args))
+    wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $

compiler/coreSyn/CoreFVs.lhs

@@ -422,7 +422,7 @@ idUnfoldingVars :: Id -> VarSet
 idUnfoldingVars id
   = case realIdUnfolding id of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-      		             | isInlineRuleSource src
+      		             | isStableSource src
 	                     -> exprFreeVars rhs
       DFunUnfolding _ _ args -> exprsFreeVars args
       _                      -> emptyVarSet

compiler/coreSyn/CoreSubst.lhs

@@ -555,9 +555,9 @@ substUnfolding subst (DFunUnfolding ar con args)
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
 	-- Retain an InlineRule!
-  | not (isInlineRuleSource src)  -- Always zap a CoreUnfolding, to save substitution work
+  | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work
   = NoUnfolding
-  | otherwise                     -- But keep an InlineRule!
+  | otherwise                 -- But keep a stable one!
   = seqExpr new_tmpl `seq` 
     new_src `seq`
     unf { uf_tmpl = new_tmpl, uf_src = new_src }
@@ -576,7 +576,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
       _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr 
                 --             <+> ifPprDebug (equals <+> ppr wkr_expr) )   
 			      -- Note [Worker inlining]
-                InlineRule    -- It's not a wrapper any more, but still inline it!
+                InlineStable  -- It's not a wrapper any more, but still inline it!
 
   | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
   | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
@@ -584,7 +584,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
 		-- dropped as dead code, because we don't treat the UnfoldingSource
 		-- as an "occurrence".
                 -- Note [Worker inlining]
-      	        InlineRule
+      	        InlineStable
 
 substUnfoldingSource _ src = src
 

compiler/coreSyn/CoreSyn.lhs

@@ -48,8 +48,9 @@ module CoreSyn (
 	maybeUnfoldingTemplate, otherCons, unfoldingArity,
 	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-	isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
-	isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource,
+	isStableUnfolding, isStableUnfolding_maybe, 
+        isClosedUnfolding, hasSomeUnfolding, 
+	canUnfold, neverUnfoldGuidance, isStableSource,
 
 	-- * Strictness
 	seqExpr, seqExprs, seqUnfolding, 
@@ -433,17 +434,20 @@ data Unfolding
 			-- They are usually variables, but can be trivial expressions
 			-- instead (e.g. a type application).  
 
-  | CoreUnfolding {		-- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
-				-- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
+  | CoreUnfolding {		-- An unfolding for an Id with no pragma, 
+                                -- or perhaps a NOINLINE pragma
+				-- (For NOINLINE, the phase, if any, is in the 
+                                -- InlinePragInfo for this Id.)
 	uf_tmpl       :: CoreExpr,	  -- Template; occurrence info is correct
 	uf_src        :: UnfoldingSource, -- Where the unfolding came from
 	uf_is_top     :: Bool,		-- True <=> top level binding
 	uf_arity      :: Arity,		-- Number of value arguments expected
-	uf_is_value   :: Bool,		-- exprIsHNF template (cached); it is ok to discard a `seq` on
-		      			--	this variable
-        uf_is_conlike :: Bool,          -- True <=> application of constructor or CONLIKE function
+	uf_is_value   :: Bool,		-- exprIsHNF template (cached); it is ok to discard 
+		      			--	a `seq` on this variable
+        uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function
                                         --      Cached version of exprIsConLike
-	uf_is_cheap   :: Bool,		-- True <=> doesn't waste (much) work to expand inside an inlining
+	uf_is_cheap   :: Bool,		-- True <=> doesn't waste (much) work to expand 
+                                        --          inside an inlining
 					-- 	Cached version of exprIsCheap
 	uf_expandable :: Bool,		-- True <=> can expand in RULE matching
 		      	 		--      Cached version of exprIsExpandable
@@ -467,13 +471,18 @@ data Unfolding
 
 ------------------------------------------------
 data UnfoldingSource 
-  = InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
+  = InlineRhs          -- The current rhs of the function
+    		       -- Replace uf_tmpl each time around
+
+  | InlineStable       -- From an INLINE or INLINABLE pragma 
+    		       -- Do not replace uf_tmpl; instead, keep it unchanged
+    		       -- See Note [InlineRules]
+
+  | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
     		       -- Only a few primop-like things have this property 
                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
                        -- Inline absolutely always, however boring the context.
 
-  | InlineRule	       -- From an {-# INLINE #-} pragma; See Note [InlineRules]
-
   | InlineWrapper Id   -- This unfolding is a the wrapper in a 
 		       --     worker/wrapper split from the strictness analyser
 	               -- The Id is the worker-id
@@ -481,10 +490,6 @@ data UnfoldingSource
 		       --	which don't need to contain the RHS; 
 		       --	it can be derived from the strictness info
 
-  | InlineRhs          -- The current rhs of the function
-
-   -- For InlineRhs, the uf_tmpl is replaced each time around
-   -- For all the others we leave uf_tmpl alone
 
 
 -- | 'UnfoldingGuidance' says when unfolding should take place
@@ -579,11 +584,12 @@ seqGuidance _                      = ()
 \end{code}
 
 \begin{code}
-isInlineRuleSource :: UnfoldingSource -> Bool
-isInlineRuleSource InlineCompulsory   = True
-isInlineRuleSource InlineRule         = True
-isInlineRuleSource (InlineWrapper {}) = True
-isInlineRuleSource InlineRhs          = False
+isStableSource :: UnfoldingSource -> Bool
+-- Keep the unfolding template
+isStableSource InlineCompulsory   = True
+isStableSource InlineStable       = True
+isStableSource (InlineWrapper {}) = True
+isStableSource InlineRhs          = False
  
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
@@ -642,19 +648,15 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
 expandUnfolding_maybe _                                                       = Nothing
 
-isInlineRule :: Unfolding -> Bool
-isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
-isInlineRule _		                      = False
-
-isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
-isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
-   | isInlineRuleSource src
+isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
+isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
+   | isStableSource src
    = Just (src, unsat_ok)
    where
      unsat_ok = case guide of
      	      	  UnfWhen unsat_ok _ -> unsat_ok
                   _                  -> needSaturated
-isInlineRule_maybe _ = Nothing
+isStableUnfolding_maybe _ = Nothing
 
 isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
@@ -663,7 +665,7 @@ isCompulsoryUnfolding _                                             = False
 isStableUnfolding :: Unfolding -> Bool
 -- True of unfoldings that should not be overwritten 
 -- by a CoreUnfolding for the RHS of a let-binding
-isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
 isStableUnfolding (DFunUnfolding {})		   = True
 isStableUnfolding _                                = False
 

compiler/coreSyn/CoreUnfold.lhs

@@ -19,8 +19,9 @@ module CoreUnfold (
 	Unfolding, UnfoldingGuidance,	-- Abstract types
 
 	noUnfolding, mkImplicitUnfolding, 
-	mkTopUnfolding, mkUnfolding, mkCoreUnfolding,
-	mkInlineRule, mkWwInlineRule,
+        mkUnfolding, mkCoreUnfolding,
+	mkTopUnfolding, mkSimpleUnfolding,
+	mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
 	mkCompulsoryUnfolding, mkDFunUnfolding,
 
 	interestingArg, ArgSummary(..),
@@ -44,7 +45,7 @@ import TcType	 	( tcSplitSigmaTy, tcSplitDFunHead )
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
-import CoreArity       ( manifestArity )
+import CoreArity       ( manifestArity, exprBotStrictness_maybe )
 import CoreUtils
 import Id
 import DataCon
@@ -63,7 +64,7 @@ import Util
 import FastTypes
 import FastString
 import Outputable
-
+import Data.Maybe
 \end{code}
 
 
@@ -75,8 +76,7 @@ import Outputable
 
 \begin{code}
 mkTopUnfolding :: Bool -> CoreExpr -> Unfolding
-mkTopUnfolding is_bottoming expr 
-  = mkUnfolding True {- Top level -} is_bottoming expr
+mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -}
 
 mkImplicitUnfolding :: CoreExpr -> Unfolding
 -- For implicit Ids, do a tiny bit of optimising first
@@ -88,44 +88,8 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
 -- top-level flag to True.  It gets set more accurately by the simplifier
 -- Simplify.simplUnfolding.
 
-mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding
-mkUnfolding top_lvl is_bottoming expr
-  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
-    		    uf_src        = InlineRhs,
-    		    uf_arity      = arity,
-		    uf_is_top 	  = top_lvl,
-		    uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-		    uf_expandable = exprIsExpandable expr,
-		    uf_is_cheap   = is_cheap,
-		    uf_guidance   = guidance }
-  where
-    is_cheap = exprIsCheap expr
-    (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) 
-                                              opt_UF_CreationThreshold expr
-	-- Sometimes during simplification, there's a large let-bound thing	
-	-- which has been substituted, and so is now dead; so 'expr' contains
-	-- two copies of the thing while the occurrence-analysed expression doesn't
-	-- Nevertheless, we *don't* occ-analyse before computing the size because the
-	-- size computation bales out after a while, whereas occurrence analysis does not.
-	--
-	-- This can occasionally mean that the guidance is very pessimistic;
-	-- it gets fixed up next round.  And it should be rare, because large
-	-- let-bound things that are dead are usually caught by preInlineUnconditionally
-
-mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
-                -> Arity -> UnfoldingGuidance -> Unfolding
--- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding top_lvl src expr arity guidance 
-  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
-    		    uf_src        = src,
-    		    uf_arity      = arity,
-		    uf_is_top 	  = top_lvl,
-		    uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-		    uf_is_cheap   = exprIsCheap      expr,
-		    uf_expandable = exprIsExpandable expr,
-		    uf_guidance   = guidance }
+mkSimpleUnfolding :: CoreExpr -> Unfolding
+mkSimpleUnfolding = mkUnfolding InlineRhs False False
 
 mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
@@ -150,10 +114,11 @@ mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolde
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
-mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding
-mkInlineRule expr mb_arity 
-  = mkCoreUnfolding True InlineRule 	 -- Note [Top-level flag on inline rules]
-    		    expr' arity 
+mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
+mkInlineUnfolding mb_arity expr 
+  = mkCoreUnfolding True 	 -- Note [Top-level flag on inline rules]
+    		    InlineStable
+                    expr' arity 
 		    (UnfWhen unsat_ok boring_ok)
   where
     expr' = simpleOptExpr expr
@@ -167,8 +132,58 @@ mkInlineRule expr mb_arity
               	  (_, UnfWhen _ boring_ok) -> boring_ok
               	  _other                   -> boringCxtNotOk
      -- See Note [INLINE for small functions]
+
+mkInlinableUnfolding :: CoreExpr -> Unfolding
+mkInlinableUnfolding expr
+  = mkUnfolding InlineStable True is_bot expr
+  where
+    is_bot = isJust (exprBotStrictness_maybe expr)
 \end{code}
 
+Internal functions
+
+\begin{code}
+mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
+                -> Arity -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding top_lvl src expr arity guidance 
+  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
+    		    uf_src        = src,
+    		    uf_arity      = arity,
+		    uf_is_top 	  = top_lvl,
+		    uf_is_value   = exprIsHNF        expr,
+                    uf_is_conlike = exprIsConLike    expr,
+		    uf_is_cheap   = exprIsCheap      expr,
+		    uf_expandable = exprIsExpandable expr,
+		    uf_guidance   = guidance }
+
+mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
+-- Calculates unfolding guidance
+-- Occurrence-analyses the expression before capturing it
+mkUnfolding src top_lvl is_bottoming expr
+  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
+    		    uf_src        = src,
+    		    uf_arity      = arity,
+		    uf_is_top 	  = top_lvl,
+		    uf_is_value   = exprIsHNF        expr,
+                    uf_is_conlike = exprIsConLike    expr,
+		    uf_expandable = exprIsExpandable expr,
+		    uf_is_cheap   = is_cheap,
+		    uf_guidance   = guidance }
+  where
+    is_cheap = exprIsCheap expr
+    (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) 
+                                              opt_UF_CreationThreshold expr
+	-- Sometimes during simplification, there's a large let-bound thing	
+	-- which has been substituted, and so is now dead; so 'expr' contains
+	-- two copies of the thing while the occurrence-analysed expression doesn't
+	-- Nevertheless, we *don't* occ-analyse before computing the size because the
+	-- size computation bales out after a while, whereas occurrence analysis does not.
+	--
+	-- This can occasionally mean that the guidance is very pessimistic;
+	-- it gets fixed up next round.  And it should be rare, because large
+	-- let-bound things that are dead are usually caught by preInlineUnconditionally
+\end{code}
 
 %************************************************************************
 %*									*

compiler/coreSyn/PprCore.lhs

@@ -382,7 +382,7 @@ instance Outputable UnfoldingGuidance where
 instance Outputable UnfoldingSource where
   ppr InlineCompulsory  = ptext (sLit "Compulsory")
   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
-  ppr InlineRule        = ptext (sLit "InlineRule")
+  ppr InlineStable      = ptext (sLit "InlineStable")
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
@@ -407,8 +407,8 @@ instance Outputable Unfolding where
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
-      pp_rhs | isInlineRuleSource src = pp_tmpl
-             | otherwise              = empty
+      pp_rhs | isStableSource src = pp_tmpl
+             | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
 	    -- blowup in the size of the printout!
 \end{code}

compiler/deSugar/DsBinds.lhs

@@ -355,21 +355,29 @@ 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)
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+      	  EmptyInlineSpec -> (gbl_id, rhs)
+      	  NoInline        -> (gbl_id, rhs)
+      	  Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline          -> inline_pair
 
-  | Just arity <- inlinePragmaSat inline_prag
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding rhs
+    inline_pair
+       | 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]
-  , let real_arity = dict_arity + arity
+       , let real_arity = dict_arity + arity
         -- NB: The arity in the InlineRule takes account of the dictionaries
-  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
-     etaExpand real_arity rhs)
+       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
 
-  | otherwise
-  = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
-  where
-    inline_prag = idInlinePragma gbl_id
 
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity

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 wrap_rhs (Just (length args))
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}

compiler/deSugar/DsMeta.hs

@@ -460,15 +460,17 @@ rep_specialise nm ty ispec loc
 rep_InlinePrag :: InlinePragma	-- Never defaultInlinePragma
                -> DsM (Core TH.InlineSpecQ)
 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
-  | Nothing            <- activation1 
-    = repInlineSpecNoPhase inline1 match1
   | Just (flag, phase) <- activation1 
-    = repInlineSpecPhase inline1 match1 flag phase
-  | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
-    where
+  = repInlineSpecPhase inline1 match1 flag phase
+  | otherwise
+  = repInlineSpecNoPhase inline1 match1
+  where
       match1      = coreBool (rep_RuleMatchInfo match)
       activation1 = rep_Activation activation
-      inline1     = coreBool inline
+      inline1     = case inline of 
+                       Inline -> coreBool True
+ 		       _other -> coreBool False
+		       -- We have no representation for Inlinable
 
       rep_RuleMatchInfo FunLike = False
       rep_RuleMatchInfo ConLike = True

compiler/hsSyn/Convert.lhs

@@ -400,7 +400,7 @@ cvtInlineSpec Nothing
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
   = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
-                 , inl_inline = inline, inl_sat = Nothing }
+                 , inl_inline = inl_spec, inl_sat = Nothing }
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
@@ -408,6 +408,10 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
     cvtRuleMatchInfo False = FunLike
     cvtRuleMatchInfo True  = ConLike
 
+    inl_spec | inline    = Inline
+             | otherwise = NoInline
+ 	     -- Currently we have no way to say Inlinable
+
     cvtActivation Nothing | inline      = AlwaysActive
                           | otherwise   = NeverActive
     cvtActivation (Just (False, phase)) = ActiveBefore phase

compiler/iface/BinIface.hs

@@ -612,6 +612,19 @@ instance Binary InlinePragma where
            d <- get bh
            return (InlinePragma a b c d)
 
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
 instance Binary HsBang where
     put_ bh HsNoBang        = putByte bh 0
     put_ bh HsStrict        = putByte bh 1
@@ -1188,8 +1201,9 @@ instance Binary IfaceInfoItem where
 	      _ -> do return HsNoCafRefs
 
 instance Binary IfaceUnfolding where
-    put_ bh (IfCoreUnfold e) = do
+    put_ bh (IfCoreUnfold s e) = do
 	putByte bh 0
+	put_ bh s
 	put_ bh e
     put_ bh (IfInlineRule a b c d) = do
 	putByte bh 1
@@ -1210,8 +1224,9 @@ instance Binary IfaceUnfolding where
     get bh = do
 	h <- getByte bh
 	case h of
-	  0 -> do e <- get bh
-		  return (IfCoreUnfold e)
+	  0 -> do s <- get bh
+		  e <- get bh
+		  return (IfCoreUnfold s e)
 	  1 -> do a <- get bh
 		  b <- get bh
 		  c <- get bh

compiler/iface/IfaceSyn.lhs

@@ -210,7 +210,8 @@ data IfaceInfoItem
 -- only later attached to the Id.  Partial reason: some are orphans.
 
 data IfaceUnfolding 
-  = IfCoreUnfold IfaceExpr
+  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+
   | IfCompulsory IfaceExpr	-- Only used for default methods, in fact
 
   | IfInlineRule Arity 
@@ -688,11 +689,13 @@ instance Outputable IfaceInfoItem where
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold e)     = parens (ppr e)
+  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
       		           	        pprParendIfaceExpr e]
-  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
-  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns)
+  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr
+                             <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
+                             <+> brackets (pprWithCommas pprParendIfaceExpr ns)
 
 
 -- -----------------------------------------------------------------------------
@@ -810,7 +813,7 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v

compiler/iface/MkIface.lhs

@@ -1535,21 +1535,23 @@ toIfaceIdInfo id_info
 
 --------------------------