Another refactoring on the shape of an Unfolding

I found that a compulsory unfolding was getting dropped on the floor,
so I took that as a hint to tidy up the data type so that it won't
happen again.  No big change in functionality.

compiler/coreSyn/CoreSubst.lhs

@@ -510,27 +510,27 @@ substUnfolding subst (DFunUnfolding con args)
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
 	-- Retain an InlineRule!
   = seqExpr new_tmpl `seq` 
-    new_mb_wkr `seq`
-    unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } }
+    new_info `seq`
+    unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } }
   where
-    new_tmpl   = substExpr subst tmpl
-    new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide)
+    new_tmpl = substExpr subst tmpl
+    new_info = substInlineRuleInfo subst (ir_info guide)
 
 substUnfolding _ (CoreUnfolding {}) = NoUnfolding	-- Discard
 	-- Always zap a CoreUnfolding, to save substitution work
 
-substUnfolding _ unf = unf	-- Otherwise no substitution to do
+substUnfolding _ unf = unf	-- NoUnfolding, OtherCon
 
 -------------------
-substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo
-substInlineRuleGuidance subst (InlWrapper wkr)
+substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo
+substInlineRuleInfo subst (InlWrapper wkr)
   = case lookupIdSubst subst wkr of
       Var w1 -> InlWrapper w1
       other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr )
-      	        InlUnSat   -- Worker has got substituted away altogether
+      	        InlVanilla -- Worker has got substituted away altogether
 			   -- (This can happen if it's trivial, via
 			   --  postInlineUnconditionally, hence only warning)
-substInlineRuleGuidance _ info = info
+substInlineRuleInfo _ info = info
 
 ------------------
 substIdOcc :: Subst -> Id -> Id

compiler/coreSyn/CoreSyn.lhs

@@ -35,7 +35,7 @@ module CoreSyn (
 	isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
 
 	-- * Unfolding data types
-	Unfolding(..),	UnfoldingGuidance(..), InlineRuleInfo(..),
+	Unfolding(..),	UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..),
 		-- Abstract everywhere but in CoreUnfold.lhs
 	
 	-- ** Constructing 'Unfolding's
@@ -440,20 +440,14 @@ data Unfolding
 ------------------------------------------------
 -- | 'UnfoldingGuidance' says when unfolding should take place
 data UnfoldingGuidance
-  = UnfoldAlways	-- There is /no original definition/, so you'd better unfold.
-			-- The unfolding is guaranteed to have no free variables
-    			-- so no need to think about it during dependency analysis
-
-  | InlineRule {	-- See Note [InlineRules]
-                        -- Be very keen to inline this
+  = InlineRule {        -- Be very keen to inline this; See Note [InlineRules]
       	       		-- The uf_tmpl is the *original* RHS; do *not* replace it on
 			--   each simlifier run.  Hence, the *actual* RHS of the function 
 			--   may be different by now, because it may have been optimised.
-      ug_ir_info :: InlineRuleInfo, 	-- Supplementary info about the InlineRule
-      ug_small :: Bool		        -- True <=> the RHS is so small (eg no bigger than a call) 
-      	             			--          that you should always inline a saturated call,
-    }				        --           regardless of how boring the context is
-    					-- See Note [INLINE for small functions] in CoreUnfold]
+
+        ir_sat  :: InlSatFlag,  
+        ir_info :: InlineRuleInfo
+    }
 
   | UnfoldIfGoodArgs {	-- Arose from a normal Id; the info here is the
     		     	-- result of a simple analysis of the RHS
@@ -468,20 +462,29 @@ data UnfoldingGuidance
     }			  -- a context (case (thing args) of ...),
 			  -- (where there are the right number of arguments.)
 
-  | UnfoldNever
+  | UnfoldNever		  -- A variant of UnfoldIfGoodArgs, used for big RHSs
 
 data InlineRuleInfo
-  = InlSat		-- A user-specifed or compiler injected INLINE pragma
-    			-- ONLY inline when it's applied to 'arity' arguments
+  = InlAlways       -- Inline absolutely always, however boring the context.
+                    -- There is /no original definition/. Only a few primop-like things 
+		    -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding).
+
+  | InlSmall	    -- The RHS is very small (eg no bigger than a call), so inline any
+   		    -- /saturated/ application, regardless of context
+                    -- See Note [INLINE for small functions] in CoreUnfold
+
+  | InlVanilla
 
-  | InlUnSat		-- The compiler decided to "capture" the RHS into an
-    			-- InlineRule, but do not require that it appears saturated
+  | InlWrapper Id   -- This unfolding is a the wrapper in a 
+		    --     worker/wrapper split from the strictness analyser
+		    -- Used to abbreviate the uf_tmpl in interface files
+		    --	which don't need to contain the RHS; 
+		    --	it can be derived from the strictness info
+		    -- [In principle this is orthogonal to the InlSmall/InVanilla thing, 
+                    --  but it's convenient to have it here.]
 
-  | InlWrapper Id	-- This unfolding is a the wrapper in a 
-			--     worker/wrapper split from the strictness analyser
-			-- Used to abbreviate the uf_tmpl in interface files
-			--	which don't need to contain the RHS; 
-			--	it can be derived from the strictness info
+data InlSatFlag = InlSat | InlUnSat
+    -- Specifies whether to INLINE only if the thing is applied to 'arity' args
 
 ------------------------------------------------
 noUnfolding :: Unfolding
@@ -564,10 +567,10 @@ isInlineRule :: Unfolding -> Bool
 isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
 isInlineRule _		                                    = False
 
-isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo
-isInlineRule_maybe (CoreUnfolding {
-                       uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl
-isInlineRule_maybe _		                                        = Nothing
+isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag)
+isInlineRule_maybe (CoreUnfolding { uf_guidance = 
+                        InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat)
+isInlineRule_maybe _		                                      = Nothing
 
 isStableUnfolding :: Unfolding -> Bool
 -- True of unfoldings that should not be overwritten 

compiler/coreSyn/CoreUnfold.lhs

@@ -79,21 +79,6 @@ mkImplicitUnfolding :: CoreExpr -> Unfolding
 -- For implicit Ids, do a tiny bit of optimising first
 mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
 
-mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
-mkWwInlineRule id = mkInlineRule (InlWrapper id)
-
-mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding
-mkInlineRule inl_info expr arity 
-  = mkCoreUnfolding True  	 -- Note [Top-level flag on inline rules]
-    		    expr' arity 
-		    (InlineRule { ug_ir_info = inl_info, ug_small = small })
-  where
-    expr' = simpleOptExpr expr
-    small = case calcUnfoldingGuidance (arity+1) expr' of
-              (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) 
-                   -> uncondInline arity_e size_e
-              _other {- actually UnfoldNever -} -> False
-
 -- Note [Top-level flag on inline rules]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Slight hack: note that mk_inline_rules conservatively sets the
@@ -129,9 +114,28 @@ mkCoreUnfolding top_lvl expr arity guidance
 mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
 mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
 
+mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
+mkWwInlineRule id expr arity
+  = mkCoreUnfolding True (simpleOptExpr expr) arity
+         (InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id })
+
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding expr	-- Used for things that absolutely must be unfolded
-  = mkCoreUnfolding True expr 0 UnfoldAlways	   -- Arity of unfolding doesn't matter
+mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolded
+  = mkCoreUnfolding True expr 0    -- Arity of unfolding doesn't matter
+                    (InlineRule { ir_info = InlAlways, ir_sat = InlUnSat })	
+
+mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding
+mkInlineRule sat expr arity 
+  = mkCoreUnfolding True  	 -- Note [Top-level flag on inline rules]
+    		    expr' arity 
+		    (InlineRule { ir_sat = sat, ir_info = info })
+  where
+    expr' = simpleOptExpr expr
+    info = if small then InlSmall else InlVanilla
+    small = case calcUnfoldingGuidance (arity+1) expr' of
+              (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) 
+                   -> uncondInline arity_e size_e
+              _other {- actually UnfoldNever -} -> False
 \end{code}
 
 
@@ -552,7 +556,6 @@ certainlyWillInline :: Unfolding -> Bool
   -- Sees if the unfolding is pretty certain to inline	
 certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
   = case guidance of
-      UnfoldAlways {} -> True
       UnfoldNever     -> False
       InlineRule {}   -> True
       UnfoldIfGoodArgs { ug_size = size} 
@@ -661,23 +664,19 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
 	  = case guidance of
 	      UnfoldNever  -> False
 
-	      UnfoldAlways -> True
-		-- UnfoldAlways => there is no top-level binding for
-		-- these things, so we must inline it.  Only a few
-		-- primop-like things have compulsory unfoldings (see
- 		-- MkId.lhs).  Ignore is_active because we want to
- 		-- inline even if SimplGently is on.
-
-	      InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline }
+	      InlineRule { ir_info = inl_info, ir_sat = sat }
+                 | InlAlways <- inl_info -> True         -- No top-level binding, so inline!
+		   	     		                 -- Ignore is_active because we want to 
+                                                         -- inline even if SimplGently is on.
  	         | not active_inline     -> False
 		 | n_val_args < uf_arity -> yes_unsat	 -- Not enough value args
-		 | uncond_inline         -> True	 -- Note [INLINE for small functions]
+		 | InlSmall <- inl_info  -> True         -- Note [INLINE for small functions]
 		 | otherwise	         -> some_benefit -- Saturated or over-saturated
 		 where
 		   -- See Note [Inlining an InlineRule]
-		   yes_unsat = case inl_info of
-		   	          InlSat -> False
-				  _other -> interesting_args
+		   yes_unsat = case sat of 
+                                 InlSat   -> False
+			         InlUnSat -> interesting_args
 
 	      UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
  	         | not active_inline  	      -> False
@@ -743,7 +742,7 @@ Consider	{-# INLINE f #-}
                 g y = f y
 Then f's RHS is no larger than its LHS, so we should inline it
 into even the most boring context.  (We do so if there is no INLINE
-pragma!)  That's the reason for the 'inl_small' flag on an InlineRule.
+pragma!)  That's the reason for the 'ug_small' flag on an InlineRule.
 
 
 Note [Things to watch]
@@ -899,7 +898,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
 			CaseCtxt    -> res_discount
 			_other      -> 4 `min` res_discount
 		-- res_discount can be very large when a function returns
-		-- construtors; but we only want to invoke that large discount
+		-- constructors; but we only want to invoke that large discount
 		-- when there's a case continuation.
 		-- Otherwise we, rather arbitrarily, threshold it.  Yuk.
 		-- But we want to aovid inlining large functions that return 

compiler/coreSyn/PprCore.lhs

@@ -379,20 +379,24 @@ showAttributes stuff
 \begin{code}
 instance Outputable UnfoldingGuidance where
     ppr UnfoldNever  = ptext (sLit "NEVER")
-    ppr UnfoldAlways = ptext (sLit "ALWAYS")
-    ppr (InlineRule { ug_ir_info = inl_info, ug_small = small })
-      = ptext (sLit "InlineRule") <> ppr (inl_info,small)
+    ppr (InlineRule { ir_info = info, ir_sat = sat })
+      = ptext (sLit "InlineRule") <> ppr (sat,info)
     ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
       = hsep [ ptext (sLit "IF_ARGS"), 
 	       brackets (hsep (map int cs)),
 	       int size,
 	       int discount ]
 
-instance Outputable InlineRuleInfo where
-  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+instance Outputable InlSatFlag where
   ppr InlSat         = ptext (sLit "sat")
   ppr InlUnSat       = ptext (sLit "unsat")
 
+instance Outputable InlineRuleInfo where
+  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+  ppr InlSmall       = ptext (sLit "small")
+  ppr InlAlways      = ptext (sLit "always")
+  ppr InlVanilla     = ptext (sLit "-")
+
 instance Outputable Unfolding where
   ppr NoUnfolding             = ptext (sLit "No unfolding")
   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs

compiler/iface/MkIface.lhs

@@ -1482,14 +1482,12 @@ toIfaceIdInfo id_info
 toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
 toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
   = case guidance of
-	InlineRule { ug_ir_info = InlSat } 	 -> Just (HsUnfold (IfInlineRule arity True  (toIfaceExpr rhs)))
-	InlineRule { ug_ir_info = InlUnSat }     -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
-	InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+	InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+	InlineRule { ir_sat = InlSat }        -> Just (HsUnfold (IfInlineRule arity True  (toIfaceExpr rhs)))
+	InlineRule { ir_sat = InlUnSat }      -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
 	UnfoldNever         -> Nothing
 	UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
-	UnfoldAlways	    -> panic "toIfUnfolding:UnfoldAlways"
-				-- Never happens because we never have 
-				-- bindings for unfold-always things
+
 toIfUnfolding (DFunUnfolding _con ops)
   = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
       -- No need to serialise the data constructor; 

compiler/main/TidyPgm.lhs

@@ -1055,7 +1055,7 @@ tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
 tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs 
 	      	       	 		    , uf_guidance = guide@(InlineRule {}) })
   = unf { uf_tmpl     = tidyExpr tidy_env rhs, 	   -- Preserves OccInfo
-	  uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } }
+	  uf_guidance = guide { ir_info = tidyInl tidy_env (ir_info guide) } }
 tidyUnfolding tidy_env _ (DFunUnfolding con ids)
   = DFunUnfolding con (map (tidyExpr tidy_env) ids)
 tidyUnfolding _ tidy_rhs (CoreUnfolding {})

compiler/simplCore/OccurAnal.lhs

@@ -533,7 +533,7 @@ reOrderCycle depth (bind : binds) pairs
                 -- where df is the exported dictionary. Then df makes a really
                 -- bad choice for loop breaker
 
-        | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr)
+        | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr)
 	= case inl_rule_info of
 	     InlWrapper {} -> 10  -- Note [INLINE pragmas]
 	     _other	   ->  3  -- Data structures are more important than this

compiler/simplCore/SimplUtils.lhs

@@ -410,7 +410,7 @@ Inlining is controlled partly by the SimplifierMode switch.  This has two
 settings:
 
 	SimplGently	(a) Simplifying before specialiser/full laziness
-			(b) Simplifiying inside INLINE pragma
+			(b) Simplifiying inside InlineRules
 			(c) Simplifying the LHS of a rule
 			(d) Simplifying a GHCi expression or Template 
 				Haskell splice
@@ -431,11 +431,11 @@ running it, we don't want to use -O2.  Indeed, we don't want to inline
 anything, because the byte-code interpreter might get confused about 
 unboxed tuples and suchlike.
 
-INLINE pragmas
-~~~~~~~~~~~~~~
-We don't simplify inside InlineRules (which come from INLINE pragmas).
-It really is important to switch off inlinings inside such
-expressions.  Consider the following example 
+Note [Simplifying gently inside InlineRules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do much simplification inside InlineRules (which come from
+INLINE pragmas).  It really is important to switch off inlinings
+inside such expressions.  Consider the following example
 
      	let f = \pq -> BIG
      	in
@@ -444,16 +444,14 @@ expressions.  Consider the following example
      	in ...g...g...g...g...g...
 
 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
-and thence copied multiple times when g is inlined.
+and thence copied multiple times when g is inlined.  
 
-
-This function may be inlinined in other modules, so we
-don't want to remove (by inlining) calls to functions that have
-specialisations, or that may have transformation rules in an importing
-scope.
+This function may be inlinined in other modules, so we don't want to
+remove (by inlining) calls to functions that have specialisations, or
+that may have transformation rules in an importing scope.
 
 E.g. 	{-# INLINE f #-}
-		f x = ...g...
+	f x = ...g...
 
 and suppose that g is strict *and* has specialisations.  If we inline
 g's wrapper, we deny f the chance of getting the specialised version
@@ -471,15 +469,14 @@ continuation.  That's why the keep_inline predicate returns True for
 ArgOf continuations.  It shouldn't do any harm not to dissolve the
 inline-me note under these circumstances.
 
-Note that the result is that we do very little simplification
-inside an InlineMe.  
+Although we do very little simplification inside an InlineRule,
+the RHS is simplified as normal.  For example:
 
 	all xs = foldr (&&) True xs
 	any p = all . map p  {-# INLINE any #-}
 
-Problem: any won't get deforested, and so if it's exported and the
-importer doesn't use the inlining, (eg passes it as an arg) then we
-won't get deforestation at all.  We havn't solved this problem yet!
+The RHS of 'any' will get optimised and deforested; but the InlineRule
+will still mention the original RHS.
 
 
 preInlineUnconditionally

compiler/simplCore/Simplify.lhs

@@ -656,9 +656,10 @@ simplUnfolding env top_lvl _ _ _
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_guidance = guide@(InlineRule {}) })
   = do { expr' <- simplExpr (setMode SimplGently env) expr
-       ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide)
+       	       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
+       ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide)
        ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity 
-                                 (guide { ug_ir_info = mb_wkr' })) }
+                                 (guide { ir_info = mb_wkr' })) }
 		-- See Note [Top-level flag on inline rules] in CoreUnfold
 
 simplUnfolding _ top_lvl _ occ_info new_rhs _

compiler/specialise/Specialise.lhs

@@ -29,7 +29,6 @@ import Name
 import MkId		( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes		( catMaybes, isJust )
-import BasicTypes	( Arity )
 import Bag
 import Util
 import Outputable
@@ -809,15 +808,12 @@ specDefn subst body_uds fn rhs
 
 	-- Figure out whether the function has an INLINE pragma
 	-- See Note [Inline specialisations]
-    fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity)	 -- Gives arity of the *specialised* inline rule
-    fn_has_inline_rule
-      | Just inl <- isInlineRule_maybe fn_unf 
-      = case inl of
-      	   InlWrapper _ -> Just (InlUnSat, spec_arity)
-	   _            -> Just (inl,      spec_arity)
-      | otherwise = Nothing
-      where
-        spec_arity = unfoldingArity fn_unf - n_dicts
+    fn_has_inline_rule :: Maybe InlSatFlag	-- Derive sat-flag from existing thing
+    fn_has_inline_rule = case isInlineRule_maybe fn_unf of
+                           Just (_,sat) -> Just sat
+			   Nothing      -> Nothing
+
+    spec_arity = unfoldingArity fn_unf - n_dicts  -- Arity of the *specialised* inline rule
 
     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
 
@@ -910,9 +906,9 @@ specDefn subst body_uds fn rhs
 	   	final_uds = foldr consDictBind rhs_uds dx_binds
 
 		-- See Note [Inline specialisations]
-		final_spec_f | Just (inl, spec_arity) <- fn_has_inline_rule
+		final_spec_f | Just sat <- fn_has_inline_rule
 			     = spec_f_w_arity `setInlineActivation` inline_act
-			               	      `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity
+			               	      `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
 					      	-- I'm not sure this should be unconditionally InlSat
 			     | otherwise 
 			     = spec_f_w_arity