From b173bc69180febe2763117e90624ab1906a855a8 Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Tue, 19 Nov 2019 12:43:42 +0100 Subject: Eliminate generated Con2Tag bindings completely --- compiler/typecheck/TcGenDeriv.hs | 112 ++++++++------------- .../tests/deriving/should_compile/T14682.stderr | 3 - 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 -> .... _ -> 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] -- cgit v1.2.1