Consider variables with conlike unfoldings interesting

In this expression:

  let x = f (g e1) in e2

the simplifier will inline f if it thinks that (g e1) is an interesting
argument. Until now, this was essentially the case if g was a data constructor
- we'd inline f in the hope that it will inspect and hence eliminate the
constructor application. This patch extends this mechanism to CONLIKE
functions. We consider (g e1) interesting if g is CONLIKE and inline f in the
hope that this will allow rewrite rules to match.

4 files changed, 67 insertions, 34 deletions

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 01e2be77c6..b6e7313459 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -45,7 +45,7 @@ module CoreSyn (
 	unfoldingTemplate, setUnfoldingTemplate,
 	maybeUnfoldingTemplate, otherCons, unfoldingArity,
 	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
-        isExpandableUnfolding, 
+        isExpandableUnfolding, isConLikeUnfolding,
 	isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
 	isStableUnfolding, canUnfold, neverUnfoldGuidance,
 
@@ -413,6 +413,8 @@ data Unfolding
 	uf_is_top     :: Bool,		-- True <=> top level binding
 	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
+                                        --      Cached version of exprIsConLike
 	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
@@ -496,8 +498,9 @@ mkOtherCon = OtherCon
 seqUnfolding :: Unfolding -> ()
 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, 
 		uf_is_value = b1, uf_is_cheap = b2, 
-	   	uf_expandable = b3, uf_arity = a, uf_guidance = g})
-  = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` seqGuidance g
+	   	uf_expandable = b3, uf_is_conlike = b4,
+                uf_arity = a, uf_guidance = g})
+  = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
 
 seqUnfolding _ = ()
 
@@ -541,6 +544,13 @@ isEvaldUnfolding (OtherCon _)		                    = True
 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 isEvaldUnfolding _                                          = False
 
+-- | @True@ if the unfolding is a constructor application, the application
+-- of a CONLIKE function or 'OtherCon'
+isConLikeUnfolding :: Unfolding -> Bool
+isConLikeUnfolding (OtherCon _)                             = True
+isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con
+isConLikeUnfolding _                                        = False
+
 -- | Is the thing we will unfold into certainly cheap?
 isCheapUnfolding :: Unfolding -> Bool
 isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 9e3bb4a5c0..294081464d 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -121,6 +121,7 @@ mkCoreUnfolding top_lvl expr arity guidance
     		    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 }
@@ -958,10 +959,10 @@ interestingArg e = go e 0
        	 	     	     		--    data constructors here
        | idArity v > n	   = ValueArg	-- Catches (eg) primops with arity but no unfolding
        | n > 0	           = NonTrivArg	-- Saturated or unknown call
-       | evald_unfolding   = ValueArg	-- n==0; look for a value
+       | conlike_unfolding = ValueArg	-- n==0; look for an interesting unfolding
        | otherwise	   = TrivArg	-- n==0, no useful unfolding
        where
-         evald_unfolding = isEvaldUnfolding (idUnfolding v)
+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 
     go (Type _)          _ = TrivArg
     go (App fn (Type _)) n = go fn n    
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 56a84a5ab3..50a0109c07 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -26,7 +26,7 @@ module CoreUtils (
 	-- * Properties of expressions
 	exprType, coreAltType, coreAltsType,
 	exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
-	exprIsHNF,exprOkForSpeculation, exprIsBig, 
+	exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
 	rhsIsStatic,
 
 	-- * Expression and bindings size
@@ -662,6 +662,45 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 \end{code}
 
 \begin{code}
+-- | Returns true for values or value-like expressions. These are lambdas,
+-- constructors / CONLIKE functions (as determined by the function argument)
+-- or PAPs.
+--
+exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
+exprIsHNFlike is_con is_con_unf = is_hnf_like
+  where
+    is_hnf_like (Var v) 
+                        -- NB: There are no value args at this point
+      =  is_con v   	-- Catches nullary constructors, 
+			--	so that [] and () are values, for example
+      || idArity v > 0 	-- Catches (e.g.) primops that don't have unfoldings
+      || is_con_unf (idUnfolding v)
+	-- Check the thing's unfolding; it might be bound to a value
+	-- A worry: what if an Id's unfolding is just itself: 
+	-- then we could get an infinite loop...
+
+    is_hnf_like (Lit _)          = True
+    is_hnf_like (Type _)         = True       -- Types are honorary Values;
+                                              -- we don't mind copying them
+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
+    is_hnf_like (Note _ e)       = is_hnf_like e
+    is_hnf_like (Cast e _)       = is_hnf_like e
+    is_hnf_like (App e (Type _)) = is_hnf_like e
+    is_hnf_like (App e a)        = app_is_value e [a]
+    is_hnf_like _                = False
+
+    -- There is at least one value argument
+    app_is_value :: CoreExpr -> [CoreArg] -> Bool
+    app_is_value (Var fun) args
+      = idArity fun > valArgCount args	  -- Under-applied function
+        || is_con fun    		  --  or constructor-like
+    app_is_value (Note _ f) as = app_is_value f as
+    app_is_value (Cast f _) as = app_is_value f as
+    app_is_value (App f a)  as = app_is_value f (a:as)
+    app_is_value _          _  = False
+\end{code}
+
+\begin{code}
 
 -- | This returns true for expressions that are certainly /already/ 
 -- evaluated to /head/ normal form.  This is used to decide whether it's ok 
@@ -692,34 +731,15 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
 -- unboxed type must be ok-for-speculation (or trivial).
 exprIsHNF :: CoreExpr -> Bool		-- True => Value-lambda, constructor, PAP
-exprIsHNF (Var v) 	-- NB: There are no value args at this point
-  =  isDataConWorkId v 	-- Catches nullary constructors, 
-			--	so that [] and () are values, for example
-  || idArity v > 0 	-- Catches (e.g.) primops that don't have unfoldings
-  || isEvaldUnfolding (idUnfolding v)
-	-- Check the thing's unfolding; it might be bound to a value
-	-- A worry: what if an Id's unfolding is just itself: 
-	-- then we could get an infinite loop...
+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
+\end{code}
 
-exprIsHNF (Lit _)          = True
-exprIsHNF (Type _)         = True       -- Types are honorary Values;
-                                        -- we don't mind copying them
-exprIsHNF (Lam b e)        = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note _ e)       = exprIsHNF e
-exprIsHNF (Cast e _)       = exprIsHNF e
-exprIsHNF (App e (Type _)) = exprIsHNF e
-exprIsHNF (App e a)        = app_is_value e [a]
-exprIsHNF _                = False
-
--- There is at least one value argument
-app_is_value :: CoreExpr -> [CoreArg] -> Bool
-app_is_value (Var fun) args
-  = idArity fun > valArgCount args	  -- Under-applied function
-    || isDataConWorkId fun 		  --  or data constructor
-app_is_value (Note _ f) as = app_is_value f as
-app_is_value (Cast f _) as = app_is_value f as
-app_is_value (App f a)  as = app_is_value f (a:as)
-app_is_value _          _  = False
+\begin{code}
+-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
+-- data constructors. Conlike arguments are considered interesting by the
+-- inliner.
+exprIsConLike :: CoreExpr -> Bool	-- True => lambda, conlike, PAP
+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
 \end{code}
 
 These InstPat functions go here to avoid circularity between DataCon and Id
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 55e192d34d..9213e9cd54 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -398,13 +398,15 @@ instance Outputable Unfolding where
   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
   ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
                                  <+> brackets (pprWithCommas pprParendExpr ops)
-  ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf, uf_is_cheap=cheap
+  ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
+                     , uf_is_conlike=conlike, uf_is_cheap=cheap
       		     , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
 	= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
     where
       pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top 
                      , ptext (sLit "Arity=") <> int arity
                      , ptext (sLit "Value=") <> ppr hnf
+                     , ptext (sLit "ConLike=") <> ppr conlike
                      , ptext (sLit "Cheap=") <> ppr cheap
                      , ptext (sLit "Expandable=") <> ppr exp
                      , ppr g ]