Implement INLINABLE pragma

Implements Trac #4299.  Documentation to come.

5 files changed, 102 insertions, 85 deletions

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index e5cbfc4d43..90d7619649 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/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
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 4f92b1a001..7ca5a6787b 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/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
 
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index e09e4f29d3..05cc575f97 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/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
 
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 24d633085b..18a04455fb 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/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}
 
 %************************************************************************
 %*									*
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 1908667e14..3752d1d5bd 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/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}