[Git][ghc/ghc][master] Add flags for annotating Generic{,1} methods INLINE[1] (#11068)
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 16 01:57:23 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
998803dc by Andrzej Rybczak at 2020-10-15T11:40:32+02:00
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
- - - - -
15 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- docs/users_guide/9.2.1-notes.rst
- docs/users_guide/using-optimisation.rst
- + testsuite/tests/deriving/should_compile/T11068_aggressive.hs
- + testsuite/tests/deriving/should_compile/T11068_aggressive.stderr
- testsuite/tests/deriving/should_compile/all.T
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/T11068.hs
- + testsuite/tests/perf/compiler/T11068a.hs
- + testsuite/tests/perf/compiler/T11068b.hs
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
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
=====================================
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)
=====================================
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
=====================================
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.
-}
=====================================
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
=====================================
docs/users_guide/9.2.1-notes.rst
=====================================
@@ -28,6 +28,12 @@ Compiler
since the argument was already forced in the first equation. For more
details see :ghc-flag:`-Wredundant-bang-patterns`.
+- New ``-finline-generics`` and ``-finline-generics-aggressively`` flags for
+ improving performance of generics-based algorithms.
+
+ For more details see :ghc-flag:`-finline-generics` and
+ :ghc-flag:`-finline-generics-aggressively`.
+
- Type checker plugins which work with the natural numbers now
should use ``naturalTy`` kind instead of ``typeNatKind``, which has been removed.
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -979,6 +979,50 @@ by saying ``-fno-wombat``.
which returns a constrained type. For example, a type class where one
of the methods implements a traversal.
+.. ghc-flag:: -finline-generics
+ :shortdesc: Annotate methods of derived Generic and Generic1 instances with
+ INLINE[1] pragmas based on heuristics. Implied by :ghc-flag:`-O`.
+ :type: dynamic
+ :reverse: -fno-inline-generics
+ :category:
+
+ :default: on
+ :since: 9.2.1
+
+ .. index::
+ single: inlining, controlling
+ single: unfolding, controlling
+
+ Annotate methods of derived Generic and Generic1 instances with INLINE[1]
+ pragmas based on heuristics dependent on the size of the data type in
+ question. Improves performance of generics-based algorithms as GHC is able
+ to optimize away intermediate representation more often.
+
+.. ghc-flag:: -finline-generics-aggressively
+ :shortdesc: Annotate methods of all derived Generic and Generic1 instances
+ with INLINE[1] pragmas.
+ :type: dynamic
+ :reverse: -fno-inline-generics-aggressively
+ :category:
+
+ :default: off
+ :since: 9.2.1
+
+ .. index::
+ single: inlining, controlling
+ single: unfolding, controlling
+
+ Annotate methods of all derived Generic and Generic1 instances with
+ INLINE[1] pragmas.
+
+ This flag should only be used in modules deriving Generic instances that
+ weren't considered appropriate for INLINE[1] annotations by heuristics of
+ :ghc-flag:`-finline-generics`, yet you know that doing so would be
+ beneficial.
+
+ When enabled globally it will most likely lead to worse compile times and
+ code size blowup without runtime performance gains.
+
.. ghc-flag:: -fsolve-constant-dicts
:shortdesc: When solving constraints, try to eagerly solve
super classes using available dictionaries.
=====================================
testsuite/tests/deriving/should_compile/T11068_aggressive.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -finline-generics-aggressively #-}
+module T11068_aggressive where
+
+import GHC.Generics
+
+-- For 2 data constructors -finline-generics annotates class methods of the
+-- derived Generic instance as INLINE[1] only if each has at most 5 fields.
+data X
+ = X1 Int Int Int Int Int Int Int Int Int Int
+ | X2 Int Int Int Int Int Int Int Int Int Int
+ deriving Generic
=====================================
testsuite/tests/deriving/should_compile/T11068_aggressive.stderr
=====================================
@@ -0,0 +1,250 @@
+
+==================== Derived instances ====================
+Derived class instances:
+ instance GHC.Generics.Generic T11068_aggressive.X where
+ {-# INLINE [1] GHC.Generics.from #-}
+ {-# INLINE [1] GHC.Generics.to #-}
+ GHC.Generics.from x
+ = GHC.Generics.M1
+ (case x of
+ T11068_aggressive.X1 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ -> GHC.Generics.L1
+ (GHC.Generics.M1
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10)))))))
+ T11068_aggressive.X2 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ -> GHC.Generics.R1
+ (GHC.Generics.M1
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ GHC.Generics.to (GHC.Generics.M1 x)
+ = case x of
+ (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ -> T11068_aggressive.X1 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ -> T11068_aggressive.X2 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+
+
+Derived type family instances:
+ type GHC.Generics.Rep T11068_aggressive.X = GHC.Generics.D1
+ ('GHC.Generics.MetaData
+ "X" "T11068_aggressive" "main" 'GHC.Types.False)
+ (GHC.Generics.C1
+ ('GHC.Generics.MetaCons
+ "X1" 'GHC.Generics.PrefixI 'GHC.Types.False)
+ (((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0 GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))
+ GHC.Generics.:*: ((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)))))
+ GHC.Generics.:+: GHC.Generics.C1
+ ('GHC.Generics.MetaCons
+ "X2"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ (((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))
+ GHC.Generics.:*: ((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))))
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -65,6 +65,7 @@ test('T7947', [], multimod_compile, ['T7947', '-v0'])
test('T10561', normal, compile, [''])
test('T10487', [], multimod_compile, ['T10487', '-v0'])
test('T10524', normal, compile, [''])
+test('T11068_aggressive', [normalise_errmsg_fun(just_the_deriving)], compile, ['-ddump-deriv -dsuppress-uniques'])
test('T11148', normal, makefile_test, [])
test('T9968', normal, compile, [''])
test('T9968a', normal, compile, [''])
=====================================
testsuite/tests/perf/compiler/Makefile
=====================================
@@ -7,3 +7,8 @@ T4007:
$(RM) -f T4007.hi T4007.o
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-rule-firings T4007.hs
+T11068:
+ $(RM) -f T11068a.hi T11068a.o T11068b.hi T11068b.o T11068.hi T11068.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068a.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068b.hs
+ -'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068.hs -ddump-simpl | grep 'Generic'
=====================================
testsuite/tests/perf/compiler/T11068.hs
=====================================
@@ -0,0 +1,104 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+module T11068 where
+
+import Control.DeepSeq
+import GHC.Generics
+
+import T11068a
+import T11068b
+
+-- X1
+
+instance NFData X1
+
+x1_id :: X1 -> X1
+x1_id = to . from
+
+x1_lens :: Lens' X1 Integer
+x1_lens = gfield @"x1_f1"
+
+-- X1'
+
+instance NFData X1'
+
+x1'_id :: X1' -> X1'
+x1'_id = to . from
+
+x1'_lens :: Lens' X1' Integer
+x1'_lens = gfield @"x1'_f1"
+
+-- X4
+
+instance NFData X4
+
+x4_id :: X4 -> X4
+x4_id = to . from
+
+x4_lens :: Lens' X4 Integer
+x4_lens = gfield @"x4_f1"
+
+-- X4'
+
+instance NFData X4'
+
+x4'_id :: X4' -> X4'
+x4'_id = to . from
+
+x4'_lens :: Lens' X4' Integer
+x4'_lens = gfield @"x4'_f1"
+
+-- X8
+
+instance NFData X8
+
+x8_id :: X8 -> X8
+x8_id = to . from
+
+x8_lens :: Lens' X8 Integer
+x8_lens = gfield @"x8_f1"
+
+-- X8'
+
+instance NFData X8'
+
+x8'_id :: X8' -> X8'
+x8'_id = to . from
+
+x8'_lens :: Lens' X8' Integer
+x8'_lens = gfield @"x8'_f1"
+
+-- X12'
+
+instance NFData X12'
+
+-- id for data types with strict fields fully optimizes up to 12x1
+x12'_id :: X12' -> X12'
+x12'_id = to . from
+
+x12'_lens :: Lens' X12' Integer
+x12'_lens = gfield @"x12'_f1"
+
+-- X16
+
+instance NFData X16
+
+x16_id :: X16 -> X16
+x16_id = to . from
+
+x16_lens :: Lens' X16 Integer
+x16_lens = gfield @"x16_f1"
+
+-- X16'
+
+instance NFData X16'
+
+x16'_lens :: Lens' X16' Integer
+x16'_lens = gfield @"x16'_f1"
+
+-- X24
+
+instance NFData X24
+
+x24_id :: X24 -> X24
+x24_id = to . from
=====================================
testsuite/tests/perf/compiler/T11068a.hs
=====================================
@@ -0,0 +1,394 @@
+{-# LANGUAGE DeriveGeneric #-}
+module T11068a where
+
+import GHC.Generics
+
+data X1
+ = X11 { x1_f1 :: Integer
+ , x1_f2 :: Integer
+ , x1_f3 :: Integer
+ , x1_f4 :: Integer
+ , x1_f5 :: Integer
+ , x1_f6 :: Integer
+ , x1_f7 :: Integer
+ , x1_f8 :: Integer
+ , x1_f9 :: Integer
+ , x1_f10 :: Integer
+ , x1_f11 :: Integer
+ , x1_f12 :: Integer
+ , x1_f13 :: Integer
+ , x1_f14 :: Integer
+ , x1_f15 :: Integer
+ , x1_f16 :: Integer
+ , x1_f17 :: Integer
+ , x1_f18 :: Integer
+ , x1_f19 :: Integer
+ , x1_f20 :: Integer
+ , x1_f21 :: Integer
+ , x1_f22 :: Integer
+ , x1_f23 :: Integer
+ , x1_f24 :: Integer
+ , x1_f25 :: Integer
+ , x1_f26 :: Integer
+ , x1_f27 :: Integer
+ , x1_f28 :: Integer
+ , x1_f29 :: Integer
+ , x1_f30 :: Integer
+ , x1_f31 :: Integer
+ , x1_f32 :: Integer
+ , x1_f33 :: Integer
+ , x1_f34 :: Integer
+ , x1_f35 :: Integer
+ , x1_f36 :: Integer
+ , x1_f37 :: Integer
+ , x1_f38 :: Integer
+ , x1_f39 :: Integer
+ , x1_f40 :: Integer
+ , x1_f41 :: Integer
+ , x1_f42 :: Integer
+ , x1_f43 :: Integer
+ , x1_f44 :: Integer
+ , x1_f45 :: Integer
+ , x1_f46 :: Integer
+ , x1_f47 :: Integer
+ , x1_f48 :: Integer
+ , x1_f49 :: Integer
+ , x1_f50 :: Integer
+ , x1_f51 :: Integer
+ , x1_f52 :: Integer
+ , x1_f53 :: Integer
+ , x1_f54 :: Integer
+ , x1_f55 :: Integer
+ , x1_f56 :: Integer
+ , x1_f57 :: Integer
+ , x1_f58 :: Integer
+ , x1_f59 :: Integer
+ , x1_f60 :: Integer
+ , x1_f61 :: Integer
+ , x1_f62 :: Integer
+ , x1_f63 :: Integer
+ , x1_f64 :: Integer
+ , x1_f65 :: Integer
+ , x1_f66 :: Integer
+ , x1_f67 :: Integer
+ , x1_f68 :: Integer
+ , x1_f69 :: Integer
+ , x1_f70 :: Integer
+ , x1_f71 :: Integer
+ , x1_f72 :: Integer
+ , x1_f73 :: Integer
+ , x1_f74 :: Integer
+ , x1_f75 :: Integer
+ , x1_f76 :: Integer
+ , x1_f77 :: Integer
+ , x1_f78 :: Integer
+ , x1_f79 :: Integer
+ , x1_f80 :: Integer
+ , x1_f81 :: Integer
+ , x1_f82 :: Integer
+ , x1_f83 :: Integer
+ , x1_f84 :: Integer
+ , x1_f85 :: Integer
+ , x1_f86 :: Integer
+ , x1_f87 :: Integer
+ , x1_f88 :: Integer
+ , x1_f89 :: Integer
+ , x1_f90 :: Integer
+ , x1_f91 :: Integer
+ , x1_f92 :: Integer
+ , x1_f93 :: Integer
+ , x1_f94 :: Integer
+ , x1_f95 :: Integer
+ , x1_f96 :: Integer
+ , x1_f97 :: Integer
+ , x1_f98 :: Integer
+ , x1_f99 :: Integer
+ , x1_f100 :: Integer
+ } deriving Generic
+
+data X1'
+ = X1'1 { x1'_f1 :: !Integer
+ , x1'_f2 :: !Integer
+ , x1'_f3 :: !Integer
+ , x1'_f4 :: !Integer
+ , x1'_f5 :: !Integer
+ , x1'_f6 :: !Integer
+ , x1'_f7 :: !Integer
+ , x1'_f8 :: !Integer
+ , x1'_f9 :: !Integer
+ , x1'_f10 :: !Integer
+ , x1'_f11 :: !Integer
+ , x1'_f12 :: !Integer
+ , x1'_f13 :: !Integer
+ , x1'_f14 :: !Integer
+ , x1'_f15 :: !Integer
+ , x1'_f16 :: !Integer
+ , x1'_f17 :: !Integer
+ , x1'_f18 :: !Integer
+ , x1'_f19 :: !Integer
+ , x1'_f20 :: !Integer
+ , x1'_f21 :: !Integer
+ , x1'_f22 :: !Integer
+ , x1'_f23 :: !Integer
+ , x1'_f24 :: !Integer
+ , x1'_f25 :: !Integer
+ , x1'_f26 :: !Integer
+ , x1'_f27 :: !Integer
+ , x1'_f28 :: !Integer
+ , x1'_f29 :: !Integer
+ , x1'_f30 :: !Integer
+ , x1'_f31 :: !Integer
+ , x1'_f32 :: !Integer
+ , x1'_f33 :: !Integer
+ , x1'_f34 :: !Integer
+ , x1'_f35 :: !Integer
+ , x1'_f36 :: !Integer
+ , x1'_f37 :: !Integer
+ , x1'_f38 :: !Integer
+ , x1'_f39 :: !Integer
+ , x1'_f40 :: !Integer
+ , x1'_f41 :: !Integer
+ , x1'_f42 :: !Integer
+ , x1'_f43 :: !Integer
+ , x1'_f44 :: !Integer
+ , x1'_f45 :: !Integer
+ , x1'_f46 :: !Integer
+ , x1'_f47 :: !Integer
+ , x1'_f48 :: !Integer
+ , x1'_f49 :: !Integer
+ , x1'_f50 :: !Integer
+ , x1'_f51 :: !Integer
+ , x1'_f52 :: !Integer
+ , x1'_f53 :: !Integer
+ , x1'_f54 :: !Integer
+ , x1'_f55 :: !Integer
+ , x1'_f56 :: !Integer
+ , x1'_f57 :: !Integer
+ , x1'_f58 :: !Integer
+ , x1'_f59 :: !Integer
+ , x1'_f60 :: !Integer
+ , x1'_f61 :: !Integer
+ , x1'_f62 :: !Integer
+ , x1'_f63 :: !Integer
+ , x1'_f64 :: !Integer
+ , x1'_f65 :: !Integer
+ , x1'_f66 :: !Integer
+ , x1'_f67 :: !Integer
+ , x1'_f68 :: !Integer
+ , x1'_f69 :: !Integer
+ , x1'_f70 :: !Integer
+ , x1'_f71 :: !Integer
+ , x1'_f72 :: !Integer
+ , x1'_f73 :: !Integer
+ , x1'_f74 :: !Integer
+ , x1'_f75 :: !Integer
+ , x1'_f76 :: !Integer
+ , x1'_f77 :: !Integer
+ , x1'_f78 :: !Integer
+ , x1'_f79 :: !Integer
+ , x1'_f80 :: !Integer
+ , x1'_f81 :: !Integer
+ , x1'_f82 :: !Integer
+ , x1'_f83 :: !Integer
+ , x1'_f84 :: !Integer
+ , x1'_f85 :: !Integer
+ , x1'_f86 :: !Integer
+ , x1'_f87 :: !Integer
+ , x1'_f88 :: !Integer
+ , x1'_f89 :: !Integer
+ , x1'_f90 :: !Integer
+ , x1'_f91 :: !Integer
+ , x1'_f92 :: !Integer
+ , x1'_f93 :: !Integer
+ , x1'_f94 :: !Integer
+ , x1'_f95 :: !Integer
+ , x1'_f96 :: !Integer
+ , x1'_f97 :: !Integer
+ , x1'_f98 :: !Integer
+ , x1'_f99 :: !Integer
+ , x1'_f100 :: !Integer
+ } deriving Generic
+
+data X4
+ = X41 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X42 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X43 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X44 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ } deriving Generic
+
+data X4'
+ = X4'1 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'2 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'3 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'4 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ } deriving Generic
+
+data X8
+ = X81 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X82 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X83 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X84 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X85 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X86 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X87 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X88 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ } deriving Generic
+
+data X8'
+ = X8'1 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'2 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'3 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'4 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'5 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'6 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'7 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'8 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ } deriving Generic
+
+data X12'
+ = X12'1 { x12'_f1 :: !Integer }
+ | X12'2 { x12'_f1 :: !Integer }
+ | X12'3 { x12'_f1 :: !Integer }
+ | X12'4 { x12'_f1 :: !Integer }
+ | X12'5 { x12'_f1 :: !Integer }
+ | X12'6 { x12'_f1 :: !Integer }
+ | X12'7 { x12'_f1 :: !Integer }
+ | X12'8 { x12'_f1 :: !Integer }
+ | X12'9 { x12'_f1 :: !Integer }
+ | X12'10 { x12'_f1 :: !Integer }
+ | X12'11 { x12'_f1 :: !Integer }
+ | X12'12 { x12'_f1 :: !Integer }
+ deriving Generic
+
+data X16
+ = X161 { x16_f1 :: Integer }
+ | X162 { x16_f1 :: Integer }
+ | X163 { x16_f1 :: Integer }
+ | X164 { x16_f1 :: Integer }
+ | X165 { x16_f1 :: Integer }
+ | X166 { x16_f1 :: Integer }
+ | X167 { x16_f1 :: Integer }
+ | X168 { x16_f1 :: Integer }
+ | X169 { x16_f1 :: Integer }
+ | X1610 { x16_f1 :: Integer }
+ | X1611 { x16_f1 :: Integer }
+ | X1612 { x16_f1 :: Integer }
+ | X1613 { x16_f1 :: Integer }
+ | X1614 { x16_f1 :: Integer }
+ | X1615 { x16_f1 :: Integer }
+ | X1616 { x16_f1 :: Integer }
+ deriving Generic
+
+data X16'
+ = X16'1 { x16'_f1 :: !Integer }
+ | X16'2 { x16'_f1 :: !Integer }
+ | X16'3 { x16'_f1 :: !Integer }
+ | X16'4 { x16'_f1 :: !Integer }
+ | X16'5 { x16'_f1 :: !Integer }
+ | X16'6 { x16'_f1 :: !Integer }
+ | X16'7 { x16'_f1 :: !Integer }
+ | X16'8 { x16'_f1 :: !Integer }
+ | X16'9 { x16'_f1 :: !Integer }
+ | X16'10 { x16'_f1 :: !Integer }
+ | X16'11 { x16'_f1 :: !Integer }
+ | X16'12 { x16'_f1 :: !Integer }
+ | X16'13 { x16'_f1 :: !Integer }
+ | X16'14 { x16'_f1 :: !Integer }
+ | X16'15 { x16'_f1 :: !Integer }
+ | X16'16 { x16'_f1 :: !Integer }
+ deriving Generic
+
+data X24
+ = X241
+ | X242
+ | X243
+ | X244
+ | X245
+ | X246
+ | X247
+ | X248
+ | X249
+ | X2410
+ | X2411
+ | X2412
+ | X2413
+ | X2414
+ | X2415
+ | X2416
+ | X2417
+ | X2418
+ | X2419
+ | X2420
+ | X2421
+ | X2422
+ | X2423
+ | X2424
+ deriving Generic
=====================================
testsuite/tests/perf/compiler/T11068b.hs
=====================================
@@ -0,0 +1,200 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T11068b (Lens', GField(..)) where
+
+import Data.Kind
+import Data.Type.Bool
+import Data.Type.Equality
+import GHC.Generics
+import GHC.TypeLits
+
+-- Code taken from the optics / generic-lens-lite library.
+
+----------------------------------------
+-- Profunctors
+
+data Context a b t = Context (b -> t) a
+ deriving Functor
+
+class Profunctor p where
+ dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
+ lmap :: (a -> b) -> p b c -> p a c
+ rmap :: (c -> d) -> p b c -> p b d
+
+class Profunctor p => Strong p where
+ first' :: p a b -> p (a, c) (b, c)
+ second' :: p a b -> p (c, a) (c, b)
+
+ linear :: LensVL s t a b -> p a b -> p s t
+ linear f = dimap
+ ((\(Context bt a) -> (a, bt)) . f (Context id))
+ (\(b, bt) -> bt b)
+ . first'
+ {-# INLINE linear #-}
+
+data Store a b s t = Store (s -> a) (s -> b -> t)
+
+instance Profunctor (Store a b) where
+ dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s))
+ lmap f (Store get set) = Store (get . f) (\s -> set (f s))
+ rmap g (Store get set) = Store get (\s -> g . set s)
+
+instance Strong (Store a b) where
+ first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c))
+ second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b))
+
+----------------------------------------
+-- Lens
+
+type LensVL s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+type LensVL' s a = LensVL s s a a
+
+newtype Lens s t a b = Lens (forall p. Strong p => p a b -> p s t)
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens get set = Lens $ dimap (\s -> (get s, s))
+ (\(b, s) -> set s b)
+ . first'
+
+lensVL :: LensVL s t a b -> Lens s t a b
+lensVL l = Lens (linear l)
+
+withLens :: Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
+withLens (Lens l) k = case l $ Store id (\_ -> id) of
+ Store get set -> k get set
+
+----------------------------------------
+-- Field
+
+class GField (name :: Symbol) s a | name s -> a where
+ gfield :: Lens' s a
+
+instance
+ ( Generic s
+ , path ~ GetPathTree name (Rep s)
+ , GFieldSum name s path (Rep s) a
+ ) => GField name s a where
+ gfield = withLens
+ (lensVL (\f s -> to <$> gfieldSum @name @s @path f (from s)))
+ (\get set -> lensVL $ \f s -> set s <$> f (get s))
+ {-# INLINE gfield #-}
+
+data Void0
+-- | Hidden instance.
+instance a ~ Void0 => GField name Void0 a where
+ gfield = lensVL id
+
+class GFieldSum (name :: Symbol) s (path :: PathTree) (g :: Type -> Type) a
+ | name g -> a where
+ gfieldSum :: LensVL' (g x) a
+
+instance
+ ( GFieldSum name s path V1 a
+ , TypeError ('Text "Type " ':<>: Quoted ('ShowType s) ':<>:
+ 'Text " has no data constructors")
+ ) => GFieldSum name s path V1 a where
+ gfieldSum = error "unreachable"
+
+instance
+ ( GFieldSum name s path g a
+ ) => GFieldSum name s path (M1 D m g) a where
+ gfieldSum f (M1 x) = M1 <$> gfieldSum @name @s @path f x
+
+instance
+ ( GFieldSum name s path1 g1 a
+ , GFieldSum name s path2 g2 a
+ ) => GFieldSum name s ('PathTree path1 path2) (g1 :+: g2) a where
+ gfieldSum f (L1 x) = L1 <$> gfieldSum @name @s @path1 f x
+ gfieldSum f (R1 y) = R1 <$> gfieldSum @name @s @path2 f y
+ {-# INLINE gfieldSum #-}
+
+instance
+ ( path ~ FromMaybe
+ (TypeError
+ ('Text "Type " ':<>: Quoted ('ShowType s) ':<>:
+ 'Text " doesn't have a field named " ':<>: Quoted ('Text name)))
+ mpath
+ , GFieldProd name s path g a
+ ) => GFieldSum name s ('PathLeaf mpath) (M1 C m g) a where
+ gfieldSum f (M1 x) = M1 <$> gfieldProd @name @s @path f x
+
+class GFieldProd (name :: Symbol) s (path :: [Path]) g a | name g -> a where
+ gfieldProd :: LensVL' (g x) a
+
+instance
+ ( GFieldProd name s path g1 a
+ ) => GFieldProd name s ('PathLeft : path) (g1 :*: g2) a where
+ gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @name @s @path f x
+
+instance
+ ( GFieldProd name s path g2 a
+ ) => GFieldProd name s ('PathRight : path) (g1 :*: g2) a where
+ gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @name @s @path f y
+
+instance
+ ( a ~ b -- for better error message if types don't match
+ ) => GFieldProd name s '[] (M1 S ('MetaSel ('Just name) su ss ds) (Rec0 b)) a where
+ gfieldProd f (M1 (K1 x)) = M1 . K1 <$> f x
+
+----------------------------------------
+-- Helpers
+
+type family Quoted (s :: ErrorMessage) :: ErrorMessage where
+ Quoted s = 'Text "‘" ':<>: s ':<>: 'Text "’"
+
+data PathTree
+ = PathTree PathTree PathTree
+ | PathLeaf (Maybe [Path])
+ | NoPath
+
+data Path = PathLeft | PathRight
+
+-- | Compute paths to a field for a generic representation of a data type.
+type family GetPathTree (name :: Symbol) g :: PathTree where
+ GetPathTree name (M1 D _ g) = GetPathTree name g
+ GetPathTree name V1 = 'NoPath
+ GetPathTree name (g1 :+: g2) = 'PathTree (GetPathTree name g1)
+ (GetPathTree name g2)
+ GetPathTree name (M1 C _ g) = 'PathLeaf (GetPath name g '[])
+
+-- | Compute path to a constructor in a sum or a field in a product.
+type family GetPath (name :: Symbol) g (acc :: [Path]) :: Maybe [Path] where
+ GetPath name (M1 D _ g) acc = GetPath name g acc
+
+ -- Find path to a constructor in a sum type
+ GetPath name (M1 C ('MetaCons name _ _) _) acc = 'Just (Reverse acc '[])
+ GetPath name (g1 :+: g2) acc = Alt (GetPath name g1 ('PathLeft : acc))
+ (GetPath name g2 ('PathRight : acc))
+
+ -- Find path to a field in a product type
+ GetPath name (M1 S ('MetaSel ('Just name) _ _ _) _) acc = 'Just (Reverse acc '[])
+ GetPath name (g1 :*: g2) acc = Alt (GetPath name g1 ('PathLeft : acc))
+ (GetPath name g2 ('PathRight : acc))
+
+ GetPath _ _ _ = 'Nothing
+
+-- | Reverse a type-level list.
+type family Reverse (xs :: [k]) (acc :: [k]) :: [k] where
+ Reverse '[] acc = acc
+ Reverse (x : xs) acc = Reverse xs (x : acc)
+
+type family FromMaybe (def :: a) (m :: Maybe a) :: a where
+ FromMaybe _ ('Just a) = a
+ FromMaybe def 'Nothing = def
+
+-- | Type-level mplus for 'Maybe'.
+type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
+ Alt ('Just a) _ = 'Just a
+ Alt _ b = b
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -178,6 +178,8 @@ test('T10370',
compile,
[''])
+test('T11068', normal, makefile_test, ['T11068'])
+
test('T10547',
[ collect_compiler_stats('bytes allocated', 4),
],
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/998803dc4dbceb36074644483e11e6183fa5355a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/998803dc4dbceb36074644483e11e6183fa5355a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201015/288d4a1d/attachment-0001.html>
More information about the ghc-commits
mailing list