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.

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 01e2be7..b6e7313 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -45,7 +45,7 @@ module CoreSyn (
        unfoldingTemplate, setUnfoldingTemplate,
        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
        unfoldingTemplate, setUnfoldingTemplate,
        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,

-        isExpandableUnfolding, 
+        isExpandableUnfolding, isConLikeUnfolding,

        isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
        isStableUnfolding, canUnfold, neverUnfoldGuidance,
 
        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_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
        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, 
 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 _ = ()
 
 
 seqUnfolding _ = ()
 

@@ -541,6 +544,13 @@ isEvaldUnfolding (OtherCon _)                                  = True
 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 isEvaldUnfolding _                                          = False
 
 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
 -- | 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 9e3bb4a..2940814 100644 (file)
--- 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_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 }
                    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
                                                --    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
        | 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    
 
     go (Type _)          _ = TrivArg
     go (App fn (Type _)) n = go fn n    

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 56a84a5..50a0109 100644 (file)
--- 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,
        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
        exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,

-       exprIsHNF,exprOkForSpeculation, exprIsBig, 
+       exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,

        rhsIsStatic,
 
        -- * Expression and bindings size
        rhsIsStatic,
 
        -- * Expression and bindings size

@@ -662,6 +662,45 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 \end{code}
 
 \begin{code}
 \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 
 
 -- | 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
 -- 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
 \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 55e192d..9213e9c 100644 (file)
--- 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 (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
                     , 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 ]
                      , ptext (sLit "Cheap=") <> ppr cheap
                      , ptext (sLit "Expandable=") <> ppr exp
                      , ppr g ]