Fix Trac #2581: inlining of record selectors

Bryan discovered that a non-trivial record selector (non-trivial in
the sense that it has to reconstruct the result value because of
UNPACK directives) weren't being inlined.  The reason was that the
unfolding generated by MkId.mRecordSelId was never being optimised
*at all*, and hence looked big, and hence wasn't inlined.

(The out-of-line version *is* put into the code of the module
and *is* optimised, which made this bug pretty puzzling.  But the
unfolding inside the record-selector-Id itself, which is a GlobalId
and hence does not get its inlining updated like LocalIds, was
big and fat.)

Solution: I wrote a very simple optimiser, CoreUnfold.simplOptExpr,
which does enough optimisation to solve this particular problem.
It's short, simple, and will be useful in other contexts.

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 7499b78..f9eae93 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -334,7 +334,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkTopUnfolding $ Note InlineMe $
+    wrap_unf = mkImplicitUnfolding $ Note InlineMe $
               mkLams wrap_tvs $ 
               mkLams eq_args $
               mkLams dict_args $ mkLams id_args $
@@ -602,9 +602,11 @@ mkRecordSelId tycon field_label
     info = noCafIdInfo
            `setCafInfo`           caf_info
            `setArityInfo`         arity
-           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
+           `setUnfoldingInfo`     unfolding
            `setAllStrictnessInfo` Just strict_sig
 
+    unfolding = mkImplicitUnfolding rhs_w_str
+
         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
         -- almost always empty.  Also note that we use max_dict_tys
         -- rather than n_dict_tys, because the latter gives an infinite loop:
@@ -862,7 +864,7 @@ mkDictSelId no_unf name clas
                 `setArityInfo`          1
                 `setAllStrictnessInfo`  Just strict_sig
                 `setUnfoldingInfo`      (if no_unf then noUnfolding
-                                                  else mkTopUnfolding rhs)
+                                                  else mkImplicitUnfolding rhs)
 
         -- We no longer use 'must-inline' on record selectors.  They'll
         -- inline like crazy if they scrutinise a constructor

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index c630277..4e8e5ef 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
 
-       noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
+       noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, 
+       mkCompulsoryUnfolding, seqUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
@@ -36,13 +37,15 @@ 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 Type
+import Type hiding( substTy, extendTvSubst )
 import PrelNames
 import Bag
 import FastTypes
@@ -62,6 +65,15 @@ import Outputable
 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)
@@ -733,3 +745,74 @@ computeDiscount n_vals_wanted arg_discounts result_discount arg_infos
     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
+    go_nonrec subst b r' body
+      | isId b
+      , 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