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.

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 4b42c0d..14eccc6 100644 (file)
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/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` 
 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
   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 _ (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 )
   = 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)
                           -- (This can happen if it's trivial, via
                           --  postInlineUnconditionally, hence only warning)

-substInlineRuleGuidance _ info = info
+substInlineRuleInfo _ info = info

 
 ------------------
 substIdOcc :: Subst -> Id -> Id
 
 ------------------
 substIdOcc :: Subst -> Id -> Id

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index b6e7313..e9e7f8d 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -35,7 +35,7 @@ module CoreSyn (
        isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
 
        -- * Unfolding data types
        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
                -- Abstract everywhere but in CoreUnfold.lhs
        
        -- ** Constructing 'Unfolding's

@@ -440,20 +440,14 @@ data Unfolding
 ------------------------------------------------
 -- | 'UnfoldingGuidance' says when unfolding should take place
 data UnfoldingGuidance
 ------------------------------------------------
 -- | '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.
                        -- 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
 
   | 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.)
 
     }                    -- 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
 
 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
 
 ------------------------------------------------
 noUnfolding :: Unfolding

@@ -564,10 +567,10 @@ isInlineRule :: Unfolding -> Bool
 isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
 isInlineRule _                                             = False
 
 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 
 
 isStableUnfolding :: Unfolding -> Bool
 -- True of unfoldings that should not be overwritten 

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 2d83a0f..d467e89 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/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)
 
 -- 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
 -- 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)
 
 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 :: 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}
 
 
 \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
   -- 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} 
       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
 
          = 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
                 | 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]
                 | 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
 
              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
                 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]
 
 
 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
                        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 
                -- when there's a case continuation.
                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.
                -- But we want to aovid inlining large functions that return 

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 9213e9c..3bdb79c 100644 (file)
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -379,20 +379,24 @@ showAttributes stuff
 \begin{code}
 instance Outputable UnfoldingGuidance where
     ppr UnfoldNever  = ptext (sLit "NEVER")
 \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 ]
 
     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")
 
   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
 instance Outputable Unfolding where
   ppr NoUnfolding             = ptext (sLit "No unfolding")
   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 549fce6..2c106b0 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/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
 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)))
        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; 
 toIfUnfolding (DFunUnfolding _con ops)
   = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
       -- No need to serialise the data constructor; 

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index fc40f5a..dbca2e3 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/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
 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 {})
 tidyUnfolding tidy_env _ (DFunUnfolding con ids)
   = DFunUnfolding con (map (tidyExpr tidy_env) ids)
 tidyUnfolding _ tidy_rhs (CoreUnfolding {})

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 91e34f8..a3e3732 100644 (file)
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/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
 
                 -- 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
        = case inl_rule_info of
             InlWrapper {} -> 10  -- Note [INLINE pragmas]
             _other        ->  3  -- Data structures are more important than this

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index c541096..56b07c4 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/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
 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
                        (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.
 
 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
 
        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,
        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 #-}
 
 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
 
 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.
 
 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 #-}
 
 
        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
 
 
 preInlineUnconditionally

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d169518..f9cbc0a 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/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
     (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 
        ; 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 _
                -- See Note [Top-level flag on inline rules] in CoreUnfold
 
 simplUnfolding _ top_lvl _ occ_info new_rhs _

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index c51b27d..b772a3f 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -29,7 +29,6 @@ import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes          ( catMaybes, isJust )
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes          ( catMaybes, isJust )

-import BasicTypes      ( Arity )

 import Bag
 import Util
 import Outputable
 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]
 
        -- 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
 
 
     (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_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
                             = 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
                                                -- I'm not sure this should be unconditionally InlSat
                             | otherwise 
                             = spec_f_w_arity