[Git][ghc/ghc][wip/romes/9557] 3 commits: Improve performance of deriving Show
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Sat Oct 26 10:04:07 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/9557 at Glasgow Haskell Compiler / GHC
Commits:
759ce039 by Rodrigo Mesquita at 2024-10-26T11:02:54+01:00
Improve performance of deriving Show
Significantly improves performance of deriving Show instances by
avoiding using the very polymorphic `.` operator in favour of inlining
its definition. We were generating tons of applications of it, each
which had 3 type arguments!
With the example module linked in #9557, this change makes deriving Show,
on my machine, go from taking:
* 5.5s to 3.5s with -O1
* 2.9s to 2.0s with -O0
Improves on #9557
- - - - -
6ba79887 by Rodrigo Mesquita at 2024-10-26T11:03:02+01:00
Deriving Ord: compare and <= only
Since the implementation of CLC proposal #24, the default
implementations of Ord's `<`, `>`, and `>=` are given in terms of `<=`.
This means we no longer need to generate implementations for these
methods when stock deriving `Ord`. Rather, just derive the
implementation of `compare` and `<=`, and rely on the default
implementations for the others.
Progress towards #9557
Using the same sample module from #9557 with deriving Eq, Ord, this
commit takes compilation on my machine from being:
* 4.3s to 3.2s with -O0
* 6.9s to 4.9s with -O1
- - - - -
0f7f0e60 by Rodrigo Mesquita at 2024-10-26T11:03:21+01:00
Dont' eta expand cons when deriving Data
This eta expansion was introduced with the initial commit for Linear
types.
I believe this isn't needed any longer. My guess is it is an artifact
from the initial linear types implementation: data constructors are
linear, but they shouldn't need to be eta expanded to be used as higher
order functions. I suppose in the early days this wasn't true.
For instance, this works now:
data T x = T x
f = \(x :: forall y. y -> T y) -> x True
f T -- ok!
T is linear, but can be passed where an unrestricted higher order
function is expected. I recall there being some magic around to make
this work for data constructors...
Since this works, there's no need to eta_expand the data constructors in
the derived Data instances.
On my machine, this brings the module from #9557 with deriving Data from:
* 8s to 6.2s with -O0
* 13s to 9.7s with -O1
- - - - -
2 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Deriv/Generate.hs
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Hs.Utils(
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
- nlHsDo, nlHsOpApp, nlHsPar, nlHsIf, nlHsCase, nlList,
+ nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLocatedList, nlAscribe,
@@ -598,11 +598,15 @@ nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)
+nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
nlHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+nlHsLam match = noLocA $ HsLam noAnn LamSingle
+ $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])
+
nlHsPar e = noLocA (gHsPar e)
-- nlHsIf should generate if-expressions which are NOT subject to
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -339,7 +339,7 @@ Several special cases:
See function unliftedOrdOp
Note [Game plan for deriving Ord]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
comparisons on top of it; see #2130, #4019. Reason: we don't
want to laboriously make a three-way comparison, only to extract a
@@ -350,16 +350,22 @@ binary result, something like this:
True -> False
False -> True
-This being said, we can get away with generating full code only for
-'compare' and '<' thus saving us generation of other three operators.
-Other operators can be cheaply expressed through '<':
-a <= b = not $ b < a
-a > b = b < a
-a >= b = not $ a < b
-
So for sufficiently small types (few constructors, or all nullary)
we generate all methods; for large ones we just use 'compare'.
+This being said, we can get away with generating full code only for
+'compare' and '<=' thus saving us generation of other three operators.
+Other operators can be cheaply expressed through '<=' -- indeed, that's what
+the default implementations of >, <, and >= do.
+
+Historically, derived instances defined '<' and the remaining operators as
+cheap expressions in function of it:
+ a <= b = not $ b < a
+ a > b = b < a
+ a >= b = not $ a < b
+but since the CLC proposal #24 (see 8f174e06185143674d6cbfee75c30e68805d85b8),
+it suffices to derive '<=' and rely on the
+default implementation for the others.
-}
data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
@@ -417,19 +423,10 @@ gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
other_ops
| (last_tag - first_tag) <= 2 -- 1-3 constructors
|| null non_nullary_cons -- Or it's an enumeration
- = [mkOrdOp OrdLT, lE, gT, gE]
+ = [mkOrdOp OrdLE]
| otherwise
= []
- negate_expr = nlHsApp (nlHsVar not_RDR)
- pats = noLocA [a_Pat, b_Pat]
- lE = mkSimpleGeneratedFunBind loc le_RDR pats $
- negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
- gT = mkSimpleGeneratedFunBind loc gt_RDR pats $
- nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
- gE = mkSimpleGeneratedFunBind loc ge_RDR pats $
- negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
-
get_tag con = dataConTag con - fIRST_TAG
-- We want *zero-based* tags, because that's what
-- con2Tag returns (generated by untag_Expr)!
@@ -1407,7 +1404,7 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
gfoldl_eqn con
= ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
- foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)
+ foldl' mk_k_app (z_Expr `nlHsApp` (nlHsVar (getRdrName con))) as_needed)
where
con_name :: RdrName
con_name = getRdrName con
@@ -1427,16 +1424,17 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
mk_unfold_rhs dc = foldr nlHsApp
- (z_Expr `nlHsApp` (eta_expand_data_con dc))
+ (z_Expr `nlHsApp` (nlHsVar (getRdrName dc)))
(replicate (dataConSourceArity dc) (nlHsVar k_RDR))
- eta_expand_data_con dc =
- mkHsLam (noLocA eta_expand_pats)
- (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
- where
- eta_expand_pats = map nlVarPat eta_expand_vars
- eta_expand_hsvars = map nlHsVar eta_expand_vars
- eta_expand_vars = take (dataConSourceArity dc) as_RDRs
+ -- This was needed by the original implementation of Linear Types. But not anymore...?
+ -- eta_expand_data_con dc =
+ -- mkHsLam (noLocA eta_expand_pats)
+ -- (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
+ -- where
+ -- eta_expand_pats = map nlVarPat eta_expand_vars
+ -- eta_expand_hsvars = map nlHsVar eta_expand_vars
+ -- eta_expand_vars = take (dataConSourceArity dc) as_RDRs
mk_unfold_pat dc -- Last one is a wild-pat, to avoid
@@ -2528,11 +2526,14 @@ showParen_Expr
showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-
-nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
-nested_compose_Expr [e] = parenify e
-nested_compose_Expr (e:es)
- = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
+nested_compose_Expr =
+ nlHsLam . mkSimpleMatch (LamAlt LamSingle) (noLocA [z_Pat]) . go
+ where
+ -- Inlined nested applications of (`.`) to speed up deriving!
+ go [] = panic "nested_compose_expr" -- Arg is always non-empty
+ go [e] = nlHsApp (parenify e) z_Expr
+ go (e:es)
+ = nlHsApp (parenify e) (go es)
-- impossible_Expr is used in case RHSs that should never happen.
-- We generate these to keep the desugarer from complaining that they *might* happen!
@@ -2573,7 +2574,7 @@ cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) ..
a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
a_Expr = nlHsVar a_RDR
-b_Expr = nlHsVar b_RDR
+-- b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_RDR
z_Expr = nlHsVar z_RDR
ltTag_Expr = nlHsVar ltTag_RDR
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ed1008080b97ce69c26ac873ba8e8f99f63881b...0f7f0e6042f6287937cf6aec2cfd0bada87f03a4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ed1008080b97ce69c26ac873ba8e8f99f63881b...0f7f0e6042f6287937cf6aec2cfd0bada87f03a4
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/20241026/cb1dbbae/attachment-0001.html>
More information about the ghc-commits
mailing list