diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-08-23 17:42:13 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-22 15:02:05 -0500 |
| commit | 887eb6ec23eed243604f71c025d280c0b854f4c4 (patch) | |
| tree | e4be1a7822ca5b44a3a79a940b16b82ee3637fe7 /compiler | |
| parent | 6fbfde95d3612fdd747b9785d409dc32e3fdd744 (diff) | |
| download | haskell-887eb6ec23eed243604f71c025d280c0b854f4c4.tar.gz | |
Enhance Data instance generation
Use `mkConstrTag` to explicitly pass the constructor tag instead of
using `mkConstr` which queries the tag at runtime by querying the index
of the constructor name (a string) in the list of constructor names.
Perf improvement:
T16577(normal) ghc/alloc 11325573876.0 9249786992.0 -18.3% GOOD
Thanks to @sgraf812 for suggesting an additional list fusion fix during
reviews.
Metric Decrease:
T16577
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 12 |
1 files changed, 6 insertions, 6 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index e0f113df15..2bda9d40c6 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -1480,7 +1480,7 @@ kind1, kind2 :: Kind kind1 = typeToTypeKind kind2 = liftedTypeKind `mkVisFunTyMany` kind1 -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, constr_RDR, dataType_RDR, @@ -1508,7 +1508,7 @@ dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag") constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") @@ -2128,12 +2128,12 @@ genAuxBindSpecOriginal dflags loc spec gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) = mkHsVarBind loc dataC_RDR rhs where - rhs = nlHsApps mkConstr_RDR constr_args + rhs = nlHsApps mkConstrTag_RDR constr_args constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar dataT_RDR -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name + = [ nlHsVar dataT_RDR -- DataType + , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name + , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag , nlList labels -- Field labels , nlHsVar fixity ] -- Fixity |