[commit: ghc] wip/T10858: deriving Ord: Less case expressions (bcefd2a)

[git at git.haskell.org]

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

On branch  : wip/T10858
Link       : http://ghc.haskell.org/trac/ghc/changeset/bcefd2af2beaa887aac483c3d830abb222dc26be/ghc

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

commit bcefd2af2beaa887aac483c3d830abb222dc26be
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Sep 8 22:37:13 2015 +0200

    deriving Ord: Less case expressions
    
    and implement each operator using the corresponding operator on the
    fields, instead of going via `compare` for all but the last field.
    
    By using the appropriate combiator, the generated code is smaller,
    which, I hope, will lead to quicker compilation.
    
    This is part of my suggestion from #10858.


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

bcefd2af2beaa887aac483c3d830abb222dc26be
 compiler/prelude/PrelNames.hs    |  6 ++++--
 compiler/typecheck/TcGenDeriv.hs | 37 +++++++++++++++++--------------------
 2 files changed, 21 insertions(+), 22 deletions(-)

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 1684a2f..f4a0529 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -611,9 +611,10 @@ compose_RDR :: RdrName
 compose_RDR             = varQual_RDR gHC_BASE (fsLit ".")
 
 not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,
-    and_RDR, range_RDR, inRange_RDR, index_RDR,
+    and_RDR, or_RDR, range_RDR, inRange_RDR, index_RDR,
     unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName
 and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")
+or_RDR                  = varQual_RDR gHC_CLASSES (fsLit "||")
 not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")
 getTag_RDR              = varQual_RDR gHC_BASE (fsLit "getTag")
 succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ")
@@ -724,7 +725,7 @@ notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
 
 
 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
-    traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
+    traverse_RDR, mempty_RDR, mappend_RDR, mappend_diamond_RDR :: RdrName
 fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")
 pure_RDR                = nameRdrName pureAName
 ap_RDR                  = nameRdrName apAName
@@ -733,6 +734,7 @@ foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
 traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
 mempty_RDR              = varQual_RDR gHC_BASE            (fsLit "mempty")
 mappend_RDR             = varQual_RDR gHC_BASE            (fsLit "mappend")
+mappend_diamond_RDR     = varQual_RDR dATA_MONOID         (fsLit "<>")
 
 ----------------------
 varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 4a1ce4f..e281a00 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -372,6 +372,16 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
+combineResult :: OrdOp -> RdrName
+-- Knowing a1 ? b2 and a2 ? b2?,
+-- how do we combine that to obtain (a1,a2) ? (b1,b2)
+combineResult OrdCompare = mappend_diamond_RDR
+combineResult OrdLT      = or_RDR
+combineResult OrdLE      = and_RDR
+combineResult OrdGE      = and_RDR
+combineResult OrdGT      = or_RDR
+
+------------
 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Ord_binds loc tycon
   | null tycon_data_cons        -- No data-cons => invoke bale-out case
@@ -491,31 +501,18 @@ mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
 mkCompareFields tycon op tys
   = go tys as_RDRs bs_RDRs
   where
+    -- Build a chain of calls to the current operator for each field, combined
+    -- with the appropriate combinator from combineResult.
     go []   _      _          = eqResult op
-    go [ty] (a:_)  (b:_)
-      | isUnLiftedType ty     = unliftedOrdOp tycon ty op a b
-      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
-    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
-                                  (ltResult op)
-                                  (go tys as bs)
-                                  (gtResult op)
+    go [ty] (a:_)  (b:_)      = mk_compare ty a b
+    go (ty:tys) (a:as) (b:bs) = genOpApp (mk_compare ty a b) (combineResult op) (go tys as bs)
     go _ _ _ = panic "mkCompareFields"
 
-    -- (mk_compare ty a b) generates
-    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
-    -- but with suitable special cases for
-    mk_compare ty a b lt eq gt
+    mk_compare ty a b
       | isUnLiftedType ty
-      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+      = unliftedOrdOp tycon ty op a b
       | otherwise
-      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
-          [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
-           mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
-           mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
-      where
-        a_expr = nlHsVar a
-        b_expr = nlHsVar b
-        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
+      = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
 
 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
 unliftedOrdOp tycon ty op a b