diff options
-rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 26 | ||||
-rw-r--r-- | testsuite/tests/deriving/perf/Makefile | 3 | ||||
-rw-r--r-- | testsuite/tests/deriving/perf/T10858.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/deriving/perf/T10858.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/deriving/perf/all.T | 7 |
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']) |