[Git][ghc/ghc][wip/andreask/eqByTag] Eliminate generated Con2Tag bindings completely
Ben Gamari
gitlab at gitlab.haskell.org
Wed Mar 18 13:57:44 UTC 2020
Ben Gamari pushed to branch wip/andreask/eqByTag at Glasgow Haskell Compiler / GHC
Commits:
b173bc69 by Andreas Klebinger at 2020-03-18T13:57:23Z
Eliminate generated Con2Tag bindings completely
- - - - -
2 changed files:
- compiler/typecheck/TcGenDeriv.hs
- testsuite/tests/deriving/should_compile/T14682.stderr
Changes:
=====================================
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
- at maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
+we use both dataToTag# and @tag2con_Foo@ functions, as well as a
+ at 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
=====================================
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]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/b173bc69180febe2763117e90624ab1906a855a8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/b173bc69180febe2763117e90624ab1906a855a8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200318/4fec23fc/attachment-0001.html>
More information about the ghc-commits
mailing list