[commit: ghc] master: Make generated Ord instances smaller (per #10858). (4ff4929)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4ff4929cbaab21a3ca867abbc1bd24ff3287a16f/ghc

>---------------------------------------------------------------

commit 4ff4929cbaab21a3ca867abbc1bd24ff3287a16f
Author: Petr Prokhorenkov <prokhorenkov at gmail.com>
Date:   Sun Sep 4 13:23:19 2016 -0400

    Make generated Ord instances smaller (per #10858).
    
    Reviewers: simonpj, bgamari, RyanGlScott, austin
    
    Reviewed By: simonpj
    
    Subscribers: nomeata, simonpj, thomie
    
    Differential Revision: https://phabricator.haskell.org/D2502
    
    GHC Trac Issues: #10858


>---------------------------------------------------------------

4ff4929cbaab21a3ca867abbc1bd24ff3287a16f
 compiler/typecheck/TcGenDeriv.hs                   | 26 +++++++++++++++++-----
 .../should_compile => deriving/perf}/Makefile      |  0
 testsuite/tests/deriving/perf/T10858.hs            | 10 +++++++++
 .../tests/deriving/perf/T10858.stdout              |  0
 testsuite/tests/deriving/perf/all.T                |  7 ++++++
 5 files changed, 38 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index f282733..f378172 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/annotations/should_compile/Makefile b/testsuite/tests/deriving/perf/Makefile
similarity index 100%
copy from testsuite/tests/annotations/should_compile/Makefile
copy to testsuite/tests/deriving/perf/Makefile
diff --git a/testsuite/tests/deriving/perf/T10858.hs b/testsuite/tests/deriving/perf/T10858.hs
new file mode 100644
index 0000000..b4eb7e8
--- /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/libraries/base/tests/IO/encoding003.stdout b/testsuite/tests/deriving/perf/T10858.stdout
similarity index 100%
copy from libraries/base/tests/IO/encoding003.stdout
copy to testsuite/tests/deriving/perf/T10858.stdout
diff --git a/testsuite/tests/deriving/perf/all.T b/testsuite/tests/deriving/perf/all.T
new file mode 100644
index 0000000..4d5996b
--- /dev/null
+++ b/testsuite/tests/deriving/perf/all.T
@@ -0,0 +1,7 @@
+test('T10858',
+     [compiler_stats_num_field('bytes allocated',
+          [ (wordsize(64), 241655120, 8) ]),
+      only_ways(['normal'])
+      ],
+     compile,
+     ['-O'])