Eliminate generated Con2Tag bindings completelywip/andreask/eqByTag

2 files changed, 41 insertions, 74 deletions

diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index b51a0a2923..4f669986d2 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -84,9 +84,8 @@ import Data.List  ( find, partition, intersperse )
 type BagDerivStuff = Bag DerivStuff
 
 data AuxBindSpec
-  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
-  | DerivTag2Con TyCon  -- ...ditto tag2Con
-  | DerivMaxTag  TyCon  -- ...and maxTag
+  = DerivTag2Con TyCon  -- The tag2Con for given TyCon
+  | DerivMaxTag  TyCon  -- ...and ditto maxTag
   deriving( Eq )
   -- All these generate ZERO-BASED tag operations
   -- I.e first constructor has tag 0
@@ -131,14 +130,14 @@ possibly zero of them).  Here's an example, with both \tr{N}ullary and
 * For nullary constructors, we emit a
   catch-all clause of the form:
 
-      (==) a b  = case (dataToTag a) of { a# ->
-                  case (con2tag_Foo b) of { b# ->
+      (==) a b  = case (dataToTag# a) of { a# ->
+                  case (dataToTag# b) of { b# ->
                   case (a# ==# b#)     of {
                     r -> r }}}
 
-  If con2tag gets inlined this leads to join point stuff, so
-  it's better to use regular pattern matching if there aren't too
-  many nullary constructors.  "Ten" is arbitrary, of course
+  An older approach preferred regular pattern matches in some cases
+  but with dataToTag# forcing it's argument, and work on improving
+  join points, this seems no longer necessary.
 
 * If there aren't any nullary constructors, we emit a simpler
   catch-all:
@@ -147,7 +146,7 @@ possibly zero of them).  Here's an example, with both \tr{N}ullary and
 
 * For the @(/=)@ method, we normally just use the default method.
   If the type is an enumeration type, we could/may/should? generate
-  special code that calls @con2tag_Foo@, much like for @(==)@ shown
+  special code that calls @dataToTag#@, much like for @(==)@ shown
   above.
 
 We thought about doing this: If we're also deriving 'Ord' for this
@@ -163,7 +162,7 @@ produced don't get through the typechecker.
 gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
 gen_Eq_binds loc tycon = do
     dflags <- getDynFlags
-    return (method_binds dflags, aux_binds)
+    return (method_binds dflags, emptyBag)
   where
     all_cons = tyConDataCons tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
@@ -192,13 +191,9 @@ gen_Eq_binds loc tycon = do
          untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
                     (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
-    aux_binds | no_tag_match_cons = emptyBag
-              | otherwise         = emptyBag
-              --unitBag $ DerivAuxBind $ DerivCon2Tag tycon
-
     method_binds dflags = unitBag (eq_bind dflags)
     eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
-                                 (map pats_etc pat_match_cons
+                                 ( map pats_etc pat_match_cons
                                    ++ fall_through_eqn dflags)
 
     ------------------------------------------------------------------
@@ -348,11 +343,8 @@ gen_Ord_binds loc tycon = do
       then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
            , emptyBag)
       else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
-           , aux_binds)
+           , emptyBag)
   where
-    aux_binds | single_con_type = emptyBag
-              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
-
         -- Note [Game plan for deriving Ord]
     other_ops dflags
       | (last_tag - first_tag) <= 2     -- 1-3 constructors
@@ -371,7 +363,7 @@ gen_Ord_binds loc tycon = do
 
     get_tag con = dataConTag con - fIRST_TAG
         -- We want *zero-based* tags, because that's what
-        -- con2Tag returns (generated by untag_Expr)!
+        -- dataToTag# returns (generated by untag_Expr)!
 
     tycon_data_cons = tyConDataCons tycon
     single_con_type = isSingleton tycon_data_cons
@@ -551,8 +543,8 @@ nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 data Foo ... = N1 | N2 | ... | Nn
 \end{verbatim}
 
-we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
-@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
+we use both dataToTag# and @tag2con_Foo@ functions, as well as a
+@maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds.
 
 \begin{verbatim}
 instance ... Enum (Foo ...) where
@@ -565,16 +557,16 @@ instance ... Enum (Foo ...) where
 
     -- or, really...
     enumFrom a
-      = case con2tag_Foo a of
+      = case dataToTag# a of
           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 
    enumFromThen a b
-     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
+     = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo]
 
     -- or, really...
     enumFromThen a b
-      = case con2tag_Foo a of { a# ->
-        case con2tag_Foo b of { b# ->
+      = case dataToTag# a of { a# ->
+        case dataToTag# b of { b# ->
         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
         }}
 \end{verbatim}
@@ -596,7 +588,7 @@ gen_Enum_binds loc tycon = do
       , from_enum      dflags
       ]
     aux_binds = listToBag $ map DerivAuxBind
-                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
+                  [DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
 
@@ -711,32 +703,32 @@ things go not too differently from @Enum@:
 \begin{verbatim}
 instance ... Ix (Foo ...) where
     range (a, b)
-      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
+      = map tag2con_Foo [dataToTag# a .. dataToTag# b]
 
     -- or, really...
     range (a, b)
-      = case (con2tag_Foo a) of { a# ->
-        case (con2tag_Foo b) of { b# ->
+      = case (dataToTag# a) of { a# ->
+        case (dataToTag# b) of { b# ->
         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
         }}
 
     -- Generate code for unsafeIndex, because using index leads
     -- to lots of redundant range tests
     unsafeIndex c@(a, b) d
-      = case (con2tag_Foo d -# con2tag_Foo a) of
+      = case (dataToTag# d -# dataToTag# a) of
                r# -> I# r#
 
     inRange (a, b) c
       = let
-            p_tag = con2tag_Foo c
+            p_tag = dataToTag# c
         in
-        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
+        p_tag >= dataToTag# a && p_tag <= dataToTag# b
 
     -- or, really...
     inRange (a, b) c
-      = case (con2tag_Foo a)   of { a_tag ->
-        case (con2tag_Foo b)   of { b_tag ->
-        case (con2tag_Foo c)   of { c_tag ->
+      = case (dataToTag# a)   of { a_tag ->
+        case (dataToTag# b)   of { b_tag ->
+        case (dataToTag# c)   of { c_tag ->
         if (c_tag >=# a_tag) then
           c_tag <=# b_tag
         else
@@ -759,8 +751,8 @@ gen_Ix_binds loc tycon = do
     dflags <- getDynFlags
     return $ if isEnumerationTyCon tycon
       then (enum_ixes dflags, listToBag $ map DerivAuxBind
-                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
-      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+                   [DerivTag2Con tycon, DerivMaxTag tycon])
+      else (single_con_ixes, emptyBag)
   where
     --------------------------------------------------------------
     enum_ixes dflags = listToBag
@@ -1939,41 +1931,18 @@ mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
 \begin{verbatim}
 data Foo ... = ...
 
-con2tag_Foo :: Foo ... -> Int#
 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
 \end{verbatim}
 
 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
+
+We also use dataToTag# heavily.
 -}
 
 genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
                   -> (LHsBind GhcPs, LSig GhcPs)
-genAuxBindSpec dflags loc (DerivCon2Tag tycon)
-  = (mkFunBindSE 0 loc rdr_name eqns,
-     L loc (TypeSig noExtField [L loc rdr_name] sig_ty))
-  where
-    rdr_name = con2tag_RDR dflags tycon
-
-    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
-             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
-             mkParentType tycon `mkVisFunTy` intPrimTy
-
-    lots_of_constructors = tyConFamilySize tycon > 8
-                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
-                        -- but we don't do vectored returns any more.
-
-    eqns | lots_of_constructors = [get_tag_eqn]
-         | otherwise = map mk_eqn (tyConDataCons tycon)
-
-    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
-
-    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
-    mk_eqn con = ([nlWildConPat con],
-                  nlHsLit (HsIntPrim NoSourceText
-                                    (toInteger ((dataConTag con) - fIRST_TAG))))
-
 genAuxBindSpec dflags loc (DerivTag2Con tycon)
   = (mkFunBindSE 0 loc rdr_name
         [([nlConVarPat intDataCon_RDR [a_RDR]],
@@ -2267,7 +2236,7 @@ untag_Expr :: DynFlags
            -> LHsExpr GhcPs -- Result expr
 untag_Expr _ _ [] expr = expr
 untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
-  {- case (getTag untag_this) of
+  {- case (dataToTag# untag_this) of
         put_tag_here -> .... <recursive on more>
           _ -> result
          -}
@@ -2386,9 +2355,8 @@ minusInt_RDR, tagToEnum_RDR :: RdrName
 minusInt_RDR  = getRdrName (primOpId IntSubOp   )
 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
 
-con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
+tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
 -- Generates Orig s RdrName, for the binding positions
-con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
 tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
 maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
 
@@ -2417,13 +2385,15 @@ mkAuxBinderName dflags parent occ_fun
 {-
 Note [Auxiliary binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-We often want to make a top-level auxiliary binding.  E.g. for comparison we have
 
-  instance Ord T where
-    compare a b = $con2tag a `compare` $con2tag b
+We often want to make a top-level auxiliary binding.  E.g. for enum we
+turn a Integer into a constructor. So we have
+
+  instance Enum T where
+    succ x = $tag2con (dataToTag x + 1)
 
-  $con2tag :: T -> Int
-  $con2tag = ...code....
+  $tag2con :: Int -> T
+  $tag2con = ...code....
 
 Of course these top-level bindings should all have distinct name, and we are
 generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 59fc405cdb..2d008debee 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -71,9 +71,6 @@ Derived class instances:
       = (GHC.Ix.inRange (a1, b1) c1
            GHC.Classes.&& GHC.Ix.inRange (a2, b2) c2)
   
-  T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX ::
-    T14682.Foo -> GHC.Prim.Int#
-  T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX (T14682.Foo _ _) = 0#
   T14682.$tFoo :: Data.Data.DataType
   T14682.$cFoo :: Data.Data.Constr
   T14682.$tFoo = Data.Data.mkDataType "Foo" [T14682.$cFoo]