Make generated Ord instances smaller (per #10858).wip/small-ord

Reviewers: simonpj, bgamari, RyanGlScott, austin

Reviewed By: simonpj

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D2502

GHC Trac Issues: #10858

5 files changed, 42 insertions, 5 deletions

diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index f282733b6a..f37817214e 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -329,7 +329,7 @@ Several special cases:
   values we can't call the overloaded functions.
   See function unliftedOrdOp
 
-Note [Do not rely on compare]
+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 Trac #2130, #4019.  Reason: we don't
@@ -341,8 +341,16 @@ 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'.
+
 -}
 
 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
@@ -395,13 +403,21 @@ gen_Ord_binds loc tycon
     aux_binds | single_con_type = emptyBag
               | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
-        -- Note [Do not rely on compare]
+        -- Note [Game plan for deriving Ord]
     other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
                 || null non_nullary_cons        -- Or it's an enumeration
-              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
+              = listToBag [mkOrdOp OrdLT, lE, gT, gE]
               | otherwise
               = emptyBag
 
+    negate_expr = nlHsApp (nlHsVar not_RDR)
+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
+        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)!
@@ -2622,11 +2638,11 @@ as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) ..
 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
-a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
+a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
     false_Expr, true_Expr, fmap_Expr,
     mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
 a_Expr          = nlHsVar a_RDR
--- b_Expr       = nlHsVar b_RDR
+b_Expr          = nlHsVar b_RDR
 c_Expr          = nlHsVar c_RDR
 f_Expr          = nlHsVar f_RDR
 z_Expr          = nlHsVar z_RDR
diff --git a/testsuite/tests/deriving/perf/Makefile b/testsuite/tests/deriving/perf/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/deriving/perf/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/deriving/perf/T10858.hs b/testsuite/tests/deriving/perf/T10858.hs
new file mode 100644
index 0000000000..b4eb7e8a45
--- /dev/null
+++ b/testsuite/tests/deriving/perf/T10858.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Prim
+
+data TestData = First Int Double String Int Int Int Int
+              | Second Char# Int# Word# Double#
+              | Third TestData TestData TestData TestData
+              deriving (Eq, Ord)
+
+main = return ()
diff --git a/testsuite/tests/deriving/perf/T10858.stdout b/testsuite/tests/deriving/perf/T10858.stdout
new file mode 100644
index 0000000000..8b13789179
--- /dev/null
+++ b/testsuite/tests/deriving/perf/T10858.stdout
@@ -0,0 +1 @@
+
diff --git a/testsuite/tests/deriving/perf/all.T b/testsuite/tests/deriving/perf/all.T
new file mode 100644
index 0000000000..09f5e93106
--- /dev/null
+++ b/testsuite/tests/deriving/perf/all.T
@@ -0,0 +1,7 @@
+test('T10858',
+     [compiler_stats_num_field('bytes allocated',
+          [ (wordsize(64), 641075800, 8) ]),
+      only_ways(['normal'])
+      ],
+     compile,
+     ['-O'])