Suppress invalid Core Lint complaint about lack of constructors

[ghc-hetmet.git] / compiler / coreSyn / CoreUnfold.lhs

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 841e2a7..b6706c1 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -18,7 +18,8 @@ find, unsurprisingly, a Core expression.
 module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 
 module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 

-       noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
+       noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, 
+       mkCompulsoryUnfolding, seqUnfolding,

        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,

@@ -27,27 +28,28 @@ module CoreUnfold (
        couldBeSmallEnoughToInline, 
        certainlyWillInline, smallEnoughToInline,
 
        couldBeSmallEnoughToInline, 
        certainlyWillInline, smallEnoughToInline,
 

-       callSiteInline, CallContInfo(..)
+       callSiteInline, CallCtxt(..)

 
     ) where
 
 
     ) where
 

-#include "HsVersions.h"
-

 import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
 import OccurAnal
 import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
 import OccurAnal

+import CoreSubst       ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst
+                       , lookupIdSubst, substBndr, substBndrs, substRecBndrs )

 import CoreUtils
 import Id
 import DataCon
 import Literal
 import PrimOp
 import IdInfo
 import CoreUtils
 import Id
 import DataCon
 import Literal
 import PrimOp
 import IdInfo

-import Type
+import Type hiding( substTy, extendTvSubst )

 import PrelNames
 import Bag
 import FastTypes
 import PrelNames
 import Bag
 import FastTypes

+import FastString

 import Outputable
 
 \end{code}
 import Outputable
 
 \end{code}

@@ -63,6 +65,15 @@ import Outputable
 mkTopUnfolding :: CoreExpr -> Unfolding
 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
 
 mkTopUnfolding :: CoreExpr -> Unfolding
 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
 

+mkImplicitUnfolding :: CoreExpr -> Unfolding
+-- For implicit Ids, do a tiny bit of optimising first
+mkImplicitUnfolding expr 
+  = CoreUnfolding (simpleOptExpr emptySubst expr)
+                 True
+                 (exprIsHNF expr)
+                 (exprIsCheap expr)
+                 (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+

 mkUnfolding :: Bool -> CoreExpr -> Unfolding
 mkUnfolding top_lvl expr
   = CoreUnfolding (occurAnalyseExpr expr)
 mkUnfolding :: Bool -> CoreExpr -> Unfolding
 mkUnfolding top_lvl expr
   = CoreUnfolding (occurAnalyseExpr expr)

@@ -85,11 +96,11 @@ mkUnfolding top_lvl expr
        -- it gets fixed up next round
 
 instance Outputable Unfolding where
        -- it gets fixed up next round
 
 instance Outputable Unfolding where

-  ppr NoUnfolding = ptext SLIT("No unfolding")
-  ppr (OtherCon cs) = ptext SLIT("OtherCon") <+> ppr cs
-  ppr (CompulsoryUnfolding e) = ptext SLIT("Compulsory") <+> ppr e
+  ppr NoUnfolding = ptext (sLit "No unfolding")
+  ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e

   ppr (CoreUnfolding e top hnf cheap g) 
   ppr (CoreUnfolding e top hnf cheap g) 

-       = ptext SLIT("Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, 
+       = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, 

                                     ppr e]
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
                                     ppr e]
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding

@@ -106,9 +117,9 @@ mkCompulsoryUnfolding expr  -- Used for things that absolutely must be unfolded
 
 \begin{code}
 instance Outputable UnfoldingGuidance where
 
 \begin{code}
 instance Outputable UnfoldingGuidance where

-    ppr UnfoldNever    = ptext SLIT("NEVER")
+    ppr UnfoldNever    = ptext (sLit "NEVER")

     ppr (UnfoldIfGoodArgs v cs size discount)
     ppr (UnfoldIfGoodArgs v cs size discount)

-      = hsep [ ptext SLIT("IF_ARGS"), int v,
+      = hsep [ ptext (sLit "IF_ARGS"), int v,

               brackets (hsep (map int cs)),
               int size,
               int discount ]
               brackets (hsep (map int cs)),
               int size,
               int discount ]

@@ -503,7 +514,7 @@ If the thing is in WHNF, there's no danger of duplicating work,
 so we can inline if it occurs once, or is small
 
 NOTE: we don't want to inline top-level functions that always diverge.
 so we can inline if it occurs once, or is small
 
 NOTE: we don't want to inline top-level functions that always diverge.

-It just makes the code bigger.  It turns out that the convenient way to prevent
+It just makes the code bigger.  Tt turns out that the convenient way to prevent

 them inlining is to give them a NOINLINE pragma, which we do in 
 StrictAnal.addStrictnessInfoToTopId
 
 them inlining is to give them a NOINLINE pragma, which we do in 
 StrictAnal.addStrictnessInfoToTopId
 

@@ -513,19 +524,25 @@ callSiteInline :: DynFlags
               -> Id                    -- The Id
               -> Bool                  -- True if there are are no arguments at all (incl type args)
               -> [Bool]                -- One for each value arg; True if it is interesting
               -> Id                    -- The Id
               -> Bool                  -- True if there are are no arguments at all (incl type args)
               -> [Bool]                -- One for each value arg; True if it is interesting

-              -> CallContInfo          -- True <=> continuation is interesting
+              -> CallCtxt              -- True <=> continuation is interesting

               -> Maybe CoreExpr        -- Unfolding, if any
 
 
               -> Maybe CoreExpr        -- Unfolding, if any
 
 

-data CallContInfo = BoringCont         
-                 | InterestingCont     -- Somewhat interesting
-                 | CaseCont            -- Very interesting; the argument of a case
-                                       -- that decomposes its scrutinee
+data CallCtxt = BoringCtxt
+
+             | ArgCtxt Bool    -- We're somewhere in the RHS of function with rules
+                               --      => be keener to inline
+                       Int     -- We *are* the argument of a function with this arg discount
+                               --      => be keener to inline
+               -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt

 
 

-instance Outputable CallContInfo where
-  ppr BoringCont      = ptext SLIT("BoringCont")
-  ppr InterestingCont = ptext SLIT("InterestingCont")
-  ppr CaseCont               = ptext SLIT("CaseCont")
+             | CaseCtxt        -- We're the scrutinee of a case
+                               -- that decomposes its scrutinee
+
+instance Outputable CallCtxt where
+  ppr BoringCtxt    = ptext (sLit "BoringCtxt")
+  ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt")
+  ppr CaseCtxt             = ptext (sLit "CaseCtxt")

 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = case idUnfolding id of {
 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = case idUnfolding id of {

@@ -569,10 +586,13 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                  -> True
 
                  | otherwise
                  -> True
 
                  | otherwise

-                 -> some_benefit && small_enough 
+                 -> some_benefit && small_enough && inline_enough_args
+

                  where
                    enough_args = n_val_args >= n_vals_wanted
                  where
                    enough_args = n_val_args >= n_vals_wanted

-                       -- Note [Enough args] 
+                    inline_enough_args =
+                      not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
+

 
                    some_benefit = or arg_infos || really_interesting_cont
                                -- There must be something interesting
 
                    some_benefit = or arg_infos || really_interesting_cont
                                -- There must be something interesting

@@ -588,17 +608,18 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
 
                    interesting_saturated_call 
                        = case cont_info of
 
                    interesting_saturated_call 
                        = case cont_info of

-                           BoringCont -> not is_top && n_vals_wanted > 0       -- Note [Nested functions] 
-                           CaseCont   -> not lone_variable || not is_value     -- Note [Lone variables]
-                           InterestingCont -> True     -- Something else interesting about continuation
+                           BoringCtxt -> not is_top && n_vals_wanted > 0       -- Note [Nested functions] 
+                           CaseCtxt   -> not lone_variable || not is_value     -- Note [Lone variables]
+                           ArgCtxt {} -> n_vals_wanted > 0 
+                               -- See Note [Inlining in ArgCtxt]

 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 
                                               res_discount' arg_infos
                    res_discount' = case cont_info of
 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 
                                               res_discount' arg_infos
                    res_discount' = case cont_info of

-                                       BoringCont      -> 0
-                                       CaseCont        -> res_discount
-                                       InterestingCont -> 4 `min` res_discount
+                                       BoringCtxt  -> 0
+                                       CaseCtxt    -> res_discount
+                                       ArgCtxt _ _ -> 4 `min` res_discount

                        -- res_discount can be very large when a function returns
                        -- construtors; but we only want to invoke that large discount
                        -- when there's a case continuation.
                        -- res_discount can be very large when a function returns
                        -- construtors; but we only want to invoke that large discount
                        -- when there's a case continuation.

@@ -611,8 +632,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
        pprTrace "Considering inlining"
                 (ppr id <+> vcat [text "active:" <+> ppr active_inline,
                                   text "arg infos" <+> ppr arg_infos,
        pprTrace "Considering inlining"
                 (ppr id <+> vcat [text "active:" <+> ppr active_inline,
                                   text "arg infos" <+> ppr arg_infos,

-                                  text "interesting continuation" <+> ppr cont_info <+> 
-                                       ppr n_val_args,
+                                  text "interesting continuation" <+> ppr cont_info,

                                   text "is value:" <+> ppr is_value,
                                   text "is cheap:" <+> ppr is_cheap,
                                   text "guidance" <+> ppr guidance,
                                   text "is value:" <+> ppr is_value,
                                   text "is cheap:" <+> ppr is_cheap,
                                   text "guidance" <+> ppr guidance,

@@ -623,16 +643,6 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
     }
 \end{code}
 
     }
 \end{code}
 

-Note [Enough args]
-~~~~~~~~~~~~~~~~~~
-At one stage we considered only inlining a function that has enough
-arguments to saturate its arity.  But we can lose from this. For
-example (f . g) might not be a saturated application of (.), but
-nevertheless f and g might usefully optimise with each other if we
-inlined (.) and f and g.  
-
-Current story (Jan08): inline even if not saturated.
-

 Note [Nested functions]
 ~~~~~~~~~~~~~~~~~~~~~~~
 If a function has a nested defn we also record some-benefit, on the
 Note [Nested functions]
 ~~~~~~~~~~~~~~~~~~~~~~~
 If a function has a nested defn we also record some-benefit, on the

@@ -645,8 +655,21 @@ branches.  Then inlining it doesn't increase allocation, but it does
 increase the chance that the constructor won't be allocated at all in
 the branches that don't use it.
 
 increase the chance that the constructor won't be allocated at all in
 the branches that don't use it.
 

+Note [Inlining in ArgCtxt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The condition (n_vals_wanted > 0) here is very important, because otherwise
+we end up inlining top-level stuff into useless places; eg
+   x = I# 3#
+   f = \y.  g x
+This can make a very big difference: it adds 16% to nofib 'integer' allocs,
+and 20% to 'power'.
+
+At one stage I replaced this condition by 'True' (leading to the above 
+slow-down).  The motivation was test eyeball/inline1.hs; but that seems
+to work ok now.
+

 Note [Lone variables]
 Note [Lone variables]

-~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
 variable appears all alone
 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
 variable appears all alone

@@ -725,3 +748,75 @@ computeDiscount n_vals_wanted arg_discounts result_discount arg_infos
     mk_arg_discount discount is_evald | is_evald  = discount
                                      | otherwise = 0
 \end{code}
     mk_arg_discount discount is_evald | is_evald  = discount
                                      | otherwise = 0
 \end{code}

+
+%************************************************************************
+%*                                                                     *
+       The Very Simple Optimiser
+%*                                                                     *
+%************************************************************************
+
+
+\begin{code}
+simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once, 
+-- or wheere the RHS is trivial
+
+simpleOptExpr subst expr
+  = go subst (occurAnalyseExpr expr)
+  where
+    go subst (Var v)          = lookupIdSubst subst v
+    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
+    go subst (Type ty)        = Type (substTy subst ty)
+    go _     (Lit lit)        = Lit lit
+    go subst (Note note e)    = Note note (go subst e)
+    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
+    go subst (Let bind body)  = go_bind subst bind body
+    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
+                             where
+                               (subst', bndr') = substBndr subst bndr
+
+    go subst (Case e b ty as) = Case (go subst e) b' 
+                                    (substTy subst ty)
+                                    (map (go_alt subst') as)
+                             where
+                                (subst', b') = substBndr subst b
+
+
+    ----------------------
+    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+                                where
+                                  (subst', bndrs') = substBndrs subst bndrs
+
+    ----------------------
+    go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
+                                      (go subst' body)
+                           where
+                             (bndrs, rhss)    = unzip prs
+                             (subst', bndrs') = substRecBndrs subst bndrs
+                             rhss'            = map (go subst') rhss
+
+    go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
+
+    ----------------------
+    go_nonrec subst b (Type ty') body
+      | isTyVar b = go (extendTvSubst subst b ty') body
+       -- let a::* = TYPE ty in <body>
+    go_nonrec subst b r' body
+      | isId b -- let x = e in <body>
+      , exprIsTrivial r' || safe_to_inline (idOccInfo b)
+      = go (extendIdSubst subst b r') body
+    go_nonrec subst b r' body
+      = Let (NonRec b' r') (go subst' body)
+      where
+       (subst', b') = substBndr subst b
+
+    ----------------------
+       -- Unconditionally safe to inline
+    safe_to_inline :: OccInfo -> Bool
+    safe_to_inline IAmDead                  = True
+    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+    safe_to_inline (IAmALoopBreaker {})     = False
+    safe_to_inline NoOccInfo                = False
+\end{code}
\ No newline at end of file