Add flags for annotating Generic{,1} methods INLINE[1] (#11068)

Makes it possible for GHC to optimize away intermediate Generic representation
for more types.

Metric Increase:
    T12227

5 files changed, 96 insertions, 21 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 9f9e9edbab..661253b856 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -158,6 +158,8 @@ data GeneralFlag
    | Opt_Specialise
    | Opt_SpecialiseAggressively
    | Opt_CrossModuleSpecialise
+   | Opt_InlineGenerics
+   | Opt_InlineGenericsAggressively
    | Opt_StaticArgumentTransformation
    | Opt_CSE
    | Opt_StgCSE
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 40e7ea1b5a..ed29aa812c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3468,6 +3468,8 @@ fFlagsDeps = [
   flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,
   flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,
   flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,
+  flagSpec "inline-generics"                  Opt_InlineGenerics,
+  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,
   flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,
   flagSpec "strictness"                       Opt_Strictness,
   flagSpec "use-rpaths"                       Opt_RPath,
@@ -3981,6 +3983,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
 
     , ([1,2],   Opt_Specialise)
     , ([1,2],   Opt_CrossModuleSpecialise)
+    , ([1,2],   Opt_InlineGenerics)
     , ([1,2],   Opt_Strictness)
     , ([1,2],   Opt_UnboxSmallStrictFields)
     , ([1,2],   Opt_CprAnal)
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 12bf79db0f..7661000723 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -2049,8 +2049,7 @@ genDerivStuff mechanism loc clas inst_tys tyvars
                         , dit_rep_tc_args = rep_tc_args
                         }
                      , dsm_stock_gen_fn = gen_fn }
-        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys
-              pure (binds, [], faminsts, field_names)
+        -> gen_fn loc rep_tc rep_tc_args inst_tys
 
       -- Try DeriveAnyClass
       DerivSpecAnyClass -> do
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 32567e1786..86a5cd7ba5 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -43,6 +43,7 @@ import GHC.Builtin.Types
 import GHC.Builtin.Names
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Monad
+import GHC.Driver.Session
 import GHC.Driver.Types
 import GHC.Utils.Error( Validity(..), andValid )
 import GHC.Types.SrcLoc
@@ -76,10 +77,12 @@ For the generic representation we need to generate:
 -}
 
 gen_Generic_binds :: GenericKind -> TyCon -> [Type]
-                 -> TcM (LHsBinds GhcPs, FamInst)
+                 -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
 gen_Generic_binds gk tc inst_tys = do
+  dflags <- getDynFlags
   repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
-  return (mkBindsRep gk tc, repTyInsts)
+  let (binds, sigs) = mkBindsRep dflags gk tc
+  return (binds, sigs, repTyInsts)
 
 {-
 ************************************************************************
@@ -332,12 +335,33 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
 
 
 -- Bindings for the Generic instance
-mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
-mkBindsRep gk tycon =
-    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
-  `unionBags`
-    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
+mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])
+mkBindsRep dflags gk tycon = (binds, sigs)
       where
+        binds = unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
+              `unionBags`
+                unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
+
+        -- See Note [Generics performance tricks]
+        sigs = if     gopt Opt_InlineGenericsAggressively dflags
+                  || (gopt Opt_InlineGenerics dflags && inlining_useful)
+               then [inline1 from01_RDR, inline1 to01_RDR]
+               else []
+         where
+           inlining_useful
+             | cons <= 1  = True
+             | cons <= 4  = max_fields <= 5
+             | cons <= 8  = max_fields <= 2
+             | cons <= 16 = max_fields <= 1
+             | cons <= 24 = max_fields == 0
+             | otherwise  = False
+             where
+               cons       = length datacons
+               max_fields = maximum $ map dataConSourceArity datacons
+
+           inline1 f = L loc . InlineSig noExtField (L loc f)
+                     $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }
+
         -- The topmost M1 (the datatype metadata) has the exact same type
         -- across all cases of a from/to definition, and can be factored out
         -- to save some allocations during typechecking.
@@ -1039,4 +1063,48 @@ factor it out reduce the typechecker's burden:
 
 A simple change, but one that pays off, since it goes turns an O(n) amount of
 coercions to an O(1) amount.
+
+Note [Generics performance tricks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generics-based algorithms tend to rely on GHC optimizing away the intermediate
+representation for optimal performance. However, the default unfolding threshold
+is usually too small for GHC to do that.
+
+The recommended approach thus far was to increase unfolding threshold, but this
+makes GHC inline more aggressively in general, whereas it should only be more
+aggresive with generics-based code.
+
+The solution is to use a heuristic that'll annotate Generic class methods with
+INLINE[1] pragmas (the explicit phase is used to give users phase control as
+they can annotate their functions with INLINE[2] or INLINE[0] if appropriate).
+
+The current heuristic was chosen by looking at how annotating Generic methods
+INLINE[1] helps with optimal code generation for several types of generic
+algorithms:
+
+* Round trip through the generic representation.
+
+* Generation of NFData instances.
+
+* Generation of field lenses.
+
+The experimentation was done by picking data types having N constructors with M
+fields each and using their derived Generic instances to generate code with the
+above algorithms.
+
+The results are threshold values for N and M (contained in
+`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually
+leads to performance improvements at both compile time (the simplifier has to do
+more work, but then there's much less code left for subsequent phases to work
+with) and run time (the generic representation of a data type is optimized
+away).
+
+The T11068 test case, which includes the algorithms mentioned above, tests that
+the generic representations of several data types optimize away using the
+threshold values in `mkBindsRep.inlining_useful`.
+
+If one uses threshold values higher what is found in
+`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE
+pragmas tends to be at best useless and at worst lead to code size blowup
+without runtime performance improvements.
 -}
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 36d6293941..9cb56bf1c5 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -222,19 +222,22 @@ data DerivSpecMechanism
         SrcSpan -> TyCon  -- dit_rep_tc
                 -> [Type] -- dit_rep_tc_args
                 -> [Type] -- inst_tys
-                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
-      -- ^ This function returns three things:
+                -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
+      -- ^ This function returns four things:
       --
       -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
       --    (e.g., @compare (T x) (T y) = compare x y@)
       --
-      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
+      -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.
+      --    Most likely INLINE pragmas for class methods.
+      --
+      -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived
       --    instance. As examples, derived 'Generic' instances require
       --    associated type family instances, and derived 'Eq' and 'Ord'
       --    instances require top-level @con2tag@ functions.
       --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
       --
-      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be
+      -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be
       --    suppressed. This is used to suppress unused warnings for record
       --    selectors when deriving 'Read', 'Show', or 'Generic'.
       --    See @Note [Deriving and unused record selectors]@.
@@ -427,7 +430,7 @@ instance Outputable DerivContext where
 data OriginativeDerivStatus
   = CanDeriveStock            -- Stock class, can derive
       (SrcSpan -> TyCon -> [Type] -> [Type]
-               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+               -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
   | StockClassError SDoc      -- Stock class, but can't do it
   | CanDeriveAnyClass         -- See Note [Deriving any class]
   | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass
@@ -566,7 +569,7 @@ hasStockDeriving
                      -> TyCon
                      -> [Type]
                      -> [Type]
-                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+                     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
 hasStockDeriving clas
   = assocMaybe gen_list (getUnique clas)
   where
@@ -575,7 +578,7 @@ hasStockDeriving clas
                    -> TyCon
                    -> [Type]
                    -> [Type]
-                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
+                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
     gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
                , (ordClassKey,         simpleM gen_Ord_binds)
                , (enumClassKey,        simpleM gen_Enum_binds)
@@ -593,7 +596,7 @@ hasStockDeriving clas
 
     simple gen_fn loc tc tc_args _
       = let (binds, deriv_stuff) = gen_fn loc tc tc_args
-        in return (binds, deriv_stuff, [])
+        in return (binds, [], deriv_stuff, [])
 
     -- Like `simple`, but monadic. The only monadic thing that these functions
     -- do is allocate new Uniques, which are used for generating the names of
@@ -601,18 +604,18 @@ hasStockDeriving clas
     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
     simpleM gen_fn loc tc tc_args _
       = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
-           ; return (binds, deriv_stuff, []) }
+           ; return (binds, [], deriv_stuff, []) }
 
     read_or_show gen_fn loc tc tc_args _
       = do { fix_env <- getDataConFixityFun tc
            ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
                  field_names          = all_field_names tc
-           ; return (binds, deriv_stuff, field_names) }
+           ; return (binds, [], deriv_stuff, field_names) }
 
     generic gen_fn _ tc _ inst_tys
-      = do { (binds, faminst) <- gen_fn tc inst_tys
+      = do { (binds, sigs, faminst) <- gen_fn tc inst_tys
            ; let field_names = all_field_names tc
-           ; return (binds, unitBag (DerivFamInst faminst), field_names) }
+           ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }
 
     -- See Note [Deriving and unused record selectors]
     all_field_names = map flSelector . concatMap dataConFieldLabels