diff options
| -rwxr-xr-x[-rw-r--r--] | compiler/ghc.cabal.in | 2 | ||||
| -rwxr-xr-x | compiler/typecheck/TcDeriv.lhs | 139 | ||||
| -rwxr-xr-x | compiler/typecheck/TcGenDeriv.lhs | 63 | ||||
| -rwxr-xr-x | compiler/typecheck/TcGenGenerics.lhs (renamed from compiler/types/Generics.lhs) | 150 |
4 files changed, 177 insertions, 177 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 01bbeb067d..09b0fb9335 100644..100755 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -394,6 +394,7 @@ Library TcExpr TcForeign TcGenDeriv + TcGenGenerics TcHsSyn TcHsType TcInstDcls @@ -418,7 +419,6 @@ Library Coercion FamInstEnv FunDeps - Generics InstEnv TyCon Kind diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index b85cba3aba..d311647db3 100755 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -13,12 +13,12 @@ module TcDeriv ( tcDeriving ) where import HsSyn import DynFlags -import Generics import TcRnMonad import FamInst import TcEnv import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff +import TcGenGenerics import InstEnv import Inst import FamInstEnv @@ -39,18 +39,14 @@ import MkId import DataCon import Maybes import RdrName -import Module import Name import NameSet import TyCon import TcType -import BuildTyCl -import BasicTypes import Var import VarSet import PrelNames import SrcLoc -import UniqSupply import Util import ListSetOps import Outputable @@ -324,7 +320,7 @@ tcDeriving tycl_decls inst_decls deriv_decls ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2) ; loc <- getSrcSpanM ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (rm_dups (unionManyBags deriv_stuff)) + genAuxBinds loc (unionManyBags deriv_stuff) ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds @@ -344,10 +340,6 @@ tcDeriving tycl_decls inst_decls deriv_decls ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } where - -- Remove duplicate requests for auxilliary bindings - rm_dups = foldrBag dup_check emptyBag - dup_check a b = if anyBag (isDupAux a) b then b else consBag a b - ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name -> Bag TyCon -- ^ Empty data constructors -> Bag TyCon -- ^ Rep type family instances @@ -1516,133 +1508,6 @@ genDerivStuff loc fix_env clas name tycon %************************************************************************ %* * -\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism} -%* * -%************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} - -\begin{code} -gen_Generic_binds :: TyCon -> Module - -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Generic_binds tc mod = do - { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod - ; metaInsts <- genDtMeta (tc, metaTyCons) - ; return ( mkBindsRep tc - , (DerivFamInst rep0TyInst) - `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) - `unionBags` metaInsts)) } - -genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon) -genGenericRepExtras tc mod = - do uniqS <- newUniqueSupply - let - -- Uniques for everyone - (uniqD:uniqs) = uniqsFromSupply uniqS - (uniqsC,us) = splitAt (length tc_cons) uniqs - uniqsS :: [[Unique]] -- Unique supply for the S datatypes - uniqsS = mkUniqsS tc_arits us - mkUniqsS [] _ = [] - mkUniqsS (n:t) us = case splitAt n us of - (us1,us2) -> us1 : mkUniqsS t us2 - - tc_name = tyConName tc - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD tc_occ - c_occ m = mkGenC tc_occ m - s_occ m n = mkGenS tc_occ m n - d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan - c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan - | (u,m) <- zip uniqsC [0..] ] - s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan - | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] distinctAbstractTyConRhs - NonRecursive False NoParentTyCon Nothing - - metaDTyCon <- mkTyCon d_name - metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] - metaSTyCons <- mapM sequence - [ [ mkTyCon s_name - | s_name <- s_namesC ] | s_namesC <- s_names ] - - let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - rep0_tycon <- tc_mkRepTyCon tc metaDts mod - - -- pprTrace "rep0" (ppr rep0_tycon) $ - return (metaDts, rep0_tycon) - -genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff -genDtMeta (tc,metaDts) = - do dflags <- getDOpts - dClas <- tcLookupClass datatypeClassName - d_dfun_name <- new_dfun_name dClas tc - cClas <- tcLookupClass constructorClassName - c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] - sClas <- tcLookupClass selectorClassName - s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc - | _ <- x ] - | x <- metaS metaDts ]) - fix_env <- getFixityEnv - - let - safeOverlap = safeLanguageOn dflags - (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - - -- Datatype - d_metaTycon = metaD metaDts - d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap - d_binds = VanillaInst dBinds [] False - d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas - [ mkTyConTy d_metaTycon ] - d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) - - -- Constructor - c_metaTycons = metaC metaDts - c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap - | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] - c_binds = [ VanillaInst c [] False | c <- cBinds ] - c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas - [ mkTyConTy c ] - c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) - | (is,bs) <- myZip1 c_insts c_binds ] - - -- Selector - s_metaTycons = metaS metaDts - s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ - NoOverlap safeOverlap)) - (myZip2 s_metaTycons s_dfun_names) - s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] - s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas - [ mkTyConTy s ] - s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is - , iBinds = bs}))) - (myZip2 s_insts s_binds) - - myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 - - myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] - myZip2 l1 l2 = - ASSERT (and (zipWith (>=) (map length l1) (map length l2))) - [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - - return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)) -\end{code} - - -%************************************************************************ -%* * \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} %* * %************************************************************************ diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 0fc6f65274..cf9c46a747 100755 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation. \begin{code} module TcGenDeriv ( - BagDerivStuff, DerivStuff(..), isDupAux, + BagDerivStuff, DerivStuff(..), gen_Bounded_binds, gen_Enum_binds, @@ -28,7 +28,7 @@ module TcGenDeriv ( deepSubtypesContaining, foldDataConArgs, gen_Foldable_binds, gen_Traversable_binds, - genAuxBind, genAuxBinds, + genAuxBinds, ordOpTbl, boxConTbl ) where @@ -187,7 +187,7 @@ gen_Eq_binds loc tycon (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] aux_binds | no_nullary_cons = emptyBag - | otherwise = unitBag $ DerivCon2Tag tycon + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon method_binds = listToBag [eq_bind, ne_bind] eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest) @@ -332,7 +332,7 @@ gen_Ord_binds loc tycon = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds) where aux_binds | single_con_type = emptyBag - | otherwise = unitBag $ DerivCon2Tag tycon + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon -- Note [Do not rely on compare] other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors @@ -559,7 +559,8 @@ gen_Enum_binds loc tycon enum_from_then, from_enum ] - aux_binds = listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] + aux_binds = listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] occ_nm = getOccString tycon @@ -717,9 +718,11 @@ gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Ix_binds loc tycon | isEnumerationTyCon tycon - = (enum_ixes, listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) + = ( enum_ixes + , listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) | otherwise - = (single_con_ixes, unitBag (DerivCon2Tag tycon)) + = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) where -------------------------------------------------------------- enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] @@ -1730,8 +1733,8 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBind :: SrcSpan -> DerivStuff -> (LHsBind RdrName, LSig RdrName) -genAuxBind loc (DerivCon2Tag tycon) +genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) +genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where @@ -1754,7 +1757,7 @@ genAuxBind loc (DerivCon2Tag tycon) mk_eqn con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -genAuxBind loc (DerivTag2Con tycon) +genAuxBindSpec loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], @@ -1765,7 +1768,7 @@ genAuxBind loc (DerivTag2Con tycon) rdr_name = tag2con_RDR tycon -genAuxBind loc (DerivMaxTag tycon) +genAuxBindSpec loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where @@ -1775,25 +1778,31 @@ genAuxBind loc (DerivMaxTag tycon) max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) --- The other cases never happen (we filter them in genAuxBinds) -genAuxBind _ _ = panic "genAuxBind" - -type SeparateBagsDerivStuff = ( Bag (LHsBind RdrName, LSig RdrName) - -- New bindings - , Bag TyCon -- New top-level datatypes - , Bag TyCon -- New family instances - , Bag (InstInfo RdrName)) -- New instances +type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings + ( Bag (LHsBind RdrName, LSig RdrName) + -- Extra bindings (used by Generic only) + , Bag TyCon -- Extra top-level datatypes + , Bag TyCon -- Extra family instances + , Bag (InstInfo RdrName)) -- Extra instances genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds loc s = foldrBag f (emptyBag, emptyBag, emptyBag, emptyBag) s where +genAuxBinds loc b = genAuxBinds' b2 where + (b1,b2) = partitionBagWith splitDerivAuxBind b + splitDerivAuxBind (DerivAuxBind x) = Left x + splitDerivAuxBind x = Right x + + rm_dups = foldrBag dup_check emptyBag + dup_check a b = if anyBag (== a) b then b else consBag a b + + genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff + genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) + , emptyBag, emptyBag, emptyBag) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff - f x@(DerivCon2Tag _) = add1 (genAuxBind loc x) - f x@(DerivTag2Con _) = add1 (genAuxBind loc x) - f x@(DerivMaxTag _) = add1 (genAuxBind loc x) - f (DerivHsBind b) = add1 b - f (DerivTyCon t) = add2 t - f (DerivFamInst t) = add3 t - f (DerivInst i) = add4 i + f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before + f (DerivHsBind b) = add1 b + f (DerivTyCon t) = add2 t + f (DerivFamInst t) = add3 t + f (DerivInst i) = add4 i add1 x (a,b,c,d) = (x `consBag` a,b,c,d) add2 x (a,b,c,d) = (a,x `consBag` b,c,d) diff --git a/compiler/types/Generics.lhs b/compiler/typecheck/TcGenGenerics.lhs index fb8b64f089..543204759c 100755 --- a/compiler/types/Generics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -7,17 +7,15 @@ The deriving code for the Generic class \begin{code} -module Generics ( canDoGenerics, - mkBindsRep, tc_mkRepTyCon, mkBindsMetaD, - MetaTyCons(..), metaTyCons2TyCons - ) where +module TcGenGenerics (canDoGenerics, gen_Generic_binds) where +import DynFlags import HsSyn import Type import TcType +import TcGenDeriv import DataCon - import TyCon import Name hiding (varName) import Module (Module, moduleName, moduleNameString) @@ -26,25 +24,153 @@ import RdrName import BasicTypes import TysWiredIn import PrelNames - --- For generation of representation types -import TcEnv (tcLookupTyCon) +import InstEnv +import TcEnv +import MkId import TcRnMonad import HscTypes import BuildTyCl - import SrcLoc import Bag import Outputable import FastString +import UniqSupply #include "HsVersions.h" \end{code} %************************************************************************ -%* * +%* * +\subsection{Bindings for the new generic deriving mechanism} +%* * +%************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} + +\begin{code} +gen_Generic_binds :: TyCon -> Module + -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Generic_binds tc mod = do + { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod + ; metaInsts <- genDtMeta (tc, metaTyCons) + ; return ( mkBindsRep tc + , (DerivFamInst rep0TyInst) + `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) + `unionBags` metaInsts)) } + +genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon) +genGenericRepExtras tc mod = + do uniqS <- newUniqueSupply + let + -- Uniques for everyone + (uniqD:uniqs) = uniqsFromSupply uniqS + (uniqsC,us) = splitAt (length tc_cons) uniqs + uniqsS :: [[Unique]] -- Unique supply for the S datatypes + uniqsS = mkUniqsS tc_arits us + mkUniqsS [] _ = [] + mkUniqsS (n:t) us = case splitAt n us of + (us1,us2) -> us1 : mkUniqsS t us2 + + tc_name = tyConName tc + tc_cons = tyConDataCons tc + tc_arits = map dataConSourceArity tc_cons + + tc_occ = nameOccName tc_name + d_occ = mkGenD tc_occ + c_occ m = mkGenC tc_occ m + s_occ m n = mkGenS tc_occ m n + d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan + c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan + | (u,m) <- zip uniqsC [0..] ] + s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan + | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] distinctAbstractTyConRhs + NonRecursive False NoParentTyCon Nothing + + metaDTyCon <- mkTyCon d_name + metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] + metaSTyCons <- mapM sequence + [ [ mkTyCon s_name + | s_name <- s_namesC ] | s_namesC <- s_names ] + + let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + + rep0_tycon <- tc_mkRepTyCon tc metaDts mod + + -- pprTrace "rep0" (ppr rep0_tycon) $ + return (metaDts, rep0_tycon) + +genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff +genDtMeta (tc,metaDts) = + do loc <- getSrcSpanM + dflags <- getDOpts + dClas <- tcLookupClass datatypeClassName + let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc + d_dfun_name <- new_dfun_name dClas tc + cClas <- tcLookupClass constructorClassName + c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] + sClas <- tcLookupClass selectorClassName + s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc + | _ <- x ] + | x <- metaS metaDts ]) + fix_env <- getFixityEnv + + let + safeOverlap = safeLanguageOn dflags + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap + d_binds = VanillaInst dBinds [] False + d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas + [ mkTyConTy d_metaTycon ] + d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) + + -- Constructor + c_metaTycons = metaC metaDts + c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap + | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] + c_binds = [ VanillaInst c [] False | c <- cBinds ] + c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas + [ mkTyConTy c ] + c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) + | (is,bs) <- myZip1 c_insts c_binds ] + + -- Selector + s_metaTycons = metaS metaDts + s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ + NoOverlap safeOverlap)) + (myZip2 s_metaTycons s_dfun_names) + s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] + s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas + [ mkTyConTy s ] + s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is + , iBinds = bs}))) + (myZip2 s_insts s_binds) + + myZip1 :: [a] -> [b] -> [(a,b)] + myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 + + myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] + myZip2 l1 l2 = + ASSERT (and (zipWith (>=) (map length l1) (map length l2))) + [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] + + return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)) +\end{code} + +%************************************************************************ +%* * \subsection{Generating representation types} -%* * +%* * %************************************************************************ \begin{code} @@ -123,7 +249,7 @@ mkBindsRep tycon = tc_mkRepTyCon :: TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to - -> Module -- JPM TODO + -> Module -- Used as the location of the new RepTy -> TcM TyCon -- Generated representation0 type tc_mkRepTyCon tycon metaDts mod = -- Consider the example input tycon `D`, where data D a b = D_ a |