From 3e0b6b2542d8464bfba365b97a6e4b95c3885f10 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 18 Sep 2006 21:50:52 +0000 Subject: [PATCH 1/1] Remove argument variance info of tycons Fri Aug 11 13:53:24 EDT 2006 Manuel M T Chakravarty * Remove argument variance info of tycons - Following SPJ's suggestion, this patch removes the variance information from type constructors. This information was computed, but never used. ** WARNING: This patch changes the format of interface files ** ** You will need to rebuild from scratch. ** --- compiler/iface/BinIface.hs | 18 ++-- compiler/iface/BuildTyCl.lhs | 18 ++-- compiler/iface/IfaceSyn.lhs | 25 ++---- compiler/iface/MkIface.lhs | 10 +-- compiler/iface/TcIface.lhs | 14 +-- compiler/prelude/TysPrim.lhs | 44 ++++------ compiler/prelude/TysWiredIn.lhs | 18 ++-- compiler/typecheck/TcHsSyn.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 82 ++++++++++++------ compiler/typecheck/TcTyDecls.lhs | 160 +---------------------------------- compiler/types/TyCon.lhs | 54 +++--------- compiler/types/TypeRep.lhs | 2 +- 12 files changed, 131 insertions(+), 316 deletions(-) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 513bf20..13be049 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -903,7 +903,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -912,15 +912,13 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 - put_ bh (IfaceSyn aq ar as at) = do + put_ bh (IfaceSyn aq ar as) = do putByte bh 3 put_ bh aq put_ bh ar put_ bh as - put_ bh at - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do putByte bh 4 put_ bh a1 put_ bh a2 @@ -928,7 +926,6 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 - put_ bh a7 get bh = do h <- getByte bh case h of @@ -945,14 +942,12 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) + return (IfaceData a1 a2 a3 a4 a5 a6 a7) 3 -> do aq <- get bh ar <- get bh as <- get bh - at <- get bh - return (IfaceSyn aq ar as at) + return (IfaceSyn aq ar as) _ -> do a1 <- get bh a2 <- get bh @@ -960,8 +955,7 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - a7 <- get bh - return (IfaceClass a1 a2 a3 a4 a5 a6 a7) + return (IfaceClass a1 a2 a3 a4 a5 a6) instance Binary IfaceInst where put_ bh (IfaceInst cls tys dfun flag orph) = do diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 5c76d55..e4c392b 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -29,7 +29,7 @@ import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), isRecursiveTyCon, tyConArity, - ArgVrcs, AlgTyConRhs(..), newTyConRhs ) + AlgTyConRhs(..), newTyConRhs ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe, @@ -45,8 +45,8 @@ import List ( nub ) \begin{code} ------------------------------------------------------ -buildSynTyCon name tvs rhs_ty arg_vrcs - = mkSynTyCon name kind tvs rhs_ty arg_vrcs +buildSynTyCon name tvs rhs_ty + = mkSynTyCon name kind tvs rhs_ty where kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) @@ -55,13 +55,13 @@ buildSynTyCon name tvs rhs_ty arg_vrcs buildAlgTyCon :: Name -> [TyVar] -> ThetaType -- Stupid theta -> AlgTyConRhs - -> ArgVrcs -> RecFlag + -> RecFlag -> Bool -- True <=> want generics functions -> Bool -- True <=> was declared in GADT syntax -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics gadt_syn - = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta +buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn + = do { let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs fields is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; fields = mkTyConSelIds tycon rhs @@ -207,10 +207,10 @@ mkTyConSelIds tycon rhs buildClass :: Name -> [TyVar] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [(Name, DefMeth, Type)] -- Method info - -> RecFlag -> ArgVrcs -- Info for type constructor + -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs +buildClass class_name tvs sc_theta fds sig_stuff tc_isrec = do { tycon_name <- newImplicitBinder class_name mkClassTyConOcc ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, @@ -253,7 +253,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; tycon = mkClassTyCon tycon_name clas_kind tvs - tc_vrcs rhs rec_clas tc_isrec + rhs rec_clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int } diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ec5d544..e01cc31 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -38,7 +38,6 @@ import IfaceType import NewDemand ( StrictSig, pprIfaceStrictSig ) import TcType ( deNoteType ) import Class ( FunDep, DefMeth, pprFundeps ) -import TyCon ( ArgVrcs ) import OccName ( OccName, parenSymOcc, occNameFS, OccSet, unionOccSets, unitOccSet ) import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) @@ -76,7 +75,6 @@ data IfaceDecl ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? - ifVrcs :: ArgVrcs, ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax ifGeneric :: Bool -- True <=> generic converter functions available } -- We need this for imported data decls, since the @@ -85,7 +83,6 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables - ifVrcs :: ArgVrcs, ifSynRhs :: IfaceType -- synonym expansion } @@ -94,8 +91,7 @@ data IfaceDecl ifTyVars :: [IfaceTvBndr], -- Type variables ifFDs :: [FunDep FastString], -- Functional dependencies ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET @@ -233,16 +229,15 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (vcat [equals <+> ppr mono_ty, - pprVrcs vrcs]) + 4 (equals <+> ppr mono_ty) pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifVrcs = vrcs}) + ifRec = isrec}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) + 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where pp_nd = case condecls of IfAbstractTyCon -> ptext SLIT("data") @@ -250,13 +245,11 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, IfNewTyCon _ -> ptext SLIT("newtype") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) + ifFDs = fds, ifSigs = sigs, ifRec = isrec}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) - 4 (vcat [pprVrcs vrcs, - pprRec isrec, + 4 (vcat [pprRec isrec, sep (map ppr sigs)]) -pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec pprGen True = ptext SLIT("Generics: yes") pprGen False = ptext SLIT("Generics: no") @@ -514,7 +507,6 @@ eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) = bool (ifName d1 == ifName d2 && ifRec d1 == ifRec d2 && - ifVrcs d1 == ifVrcs d2 && ifGadtSyntax d1 == ifGadtSyntax d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> @@ -533,8 +525,7 @@ eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) = bool (ifName d1 == ifName d2 && - ifRec d1 == ifRec d2 && - ifVrcs d1 == ifVrcs d2) &&& + ifRec d1 == ifRec d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 656ba36..be6b8ec 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -186,7 +186,7 @@ import Class ( classExtraBigSig, classTyCon ) import TyCon ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, - tyConHasGenerics, tyConArgVrcs, synTyConRhs, isGadtSyntaxTyCon, + tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec, @@ -995,8 +995,7 @@ tyThingToIfaceDecl ext (AClass clas) ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, ifSigs = map toIfaceClassOp op_stuff, - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifVrcs = tyConArgVrcs tycon } + ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas tycon = classTyCon clas @@ -1019,7 +1018,6 @@ tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifVrcs = tyConArgVrcs tycon, ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon @@ -1029,7 +1027,6 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifVrcs = tyConArgVrcs tycon, ifGeneric = tyConHasGenerics tycon } | isForeignTyCon tycon @@ -1044,8 +1041,7 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = IfAbstractTyCon, ifGadtSyntax = False, ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } + ifRec = NonRecursive} | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8134676..04154ef 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -354,7 +354,7 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, - ifVrcs = arg_vrcs, ifRec = is_rec, + ifRec = is_rec, ifGeneric = want_generic }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -363,23 +363,23 @@ tcIfaceDecl (IfaceData {ifName = occ_name, { stupid_theta <- tcIfaceCtxt ctxt ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; buildAlgTyCon tc_name tyvars stupid_theta - cons arg_vrcs is_rec want_generic gadt_syn + cons is_rec want_generic gadt_syn }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) + ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_ty <- tcIfaceType rdr_rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs)) + ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty)) } tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifSigs = rdr_sigs, - ifVrcs = tc_vrcs, ifRec = tc_isrec }) + ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons = bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -387,7 +387,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mappM tc_sig rdr_sigs ; fds <- mappM tc_fd rdr_fds - ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs + ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -407,7 +407,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name - liftedTypeKind 0 [])) } + liftedTypeKind 0)) } tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 55ee249..4cb3ef7 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -47,7 +47,7 @@ module TysPrim( import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) import OccName ( mkOccNameFS, tcName, mkTyVarOcc ) -import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon, +import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, PrimRep(..) ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unliftedTypeKind, unboxedTypeKind, @@ -171,15 +171,6 @@ openAlphaTyVars :: [TyVar] openAlphaTyVars@(openAlphaTyVar:_) = tyVarList openTypeKind openAlphaTy = mkTyVarTy openAlphaTyVar - -vrcPos,vrcZero :: (Bool,Bool) -vrcPos = (True,False) -vrcZero = (False,False) - -vrcsP,vrcsZ,vrcsZP :: ArgVrcs -vrcsP = [vrcPos] -vrcsZ = [vrcZero] -vrcsZP = [vrcZero,vrcPos] \end{code} @@ -191,11 +182,10 @@ vrcsZP = [vrcZero,vrcPos] \begin{code} -- only used herein -pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon -pcPrimTyCon name arg_vrcs rep - = mkPrimTyCon name kind arity arg_vrcs rep +pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon +pcPrimTyCon name arity rep + = mkPrimTyCon name kind arity rep where - arity = length arg_vrcs kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind result_kind = case rep of PtrRep -> unliftedTypeKind @@ -203,7 +193,7 @@ pcPrimTyCon name arg_vrcs rep pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep - = mkPrimTyCon name result_kind 0 [] rep + = mkPrimTyCon name result_kind 0 rep where result_kind = case rep of PtrRep -> unliftedTypeKind @@ -258,7 +248,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] -statePrimTyCon = pcPrimTyCon statePrimTyConName vrcsZ VoidRep +statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -266,7 +256,7 @@ RealWorld is deeply magical. It is *primitive*, but it is not RealWorld; it's only used in the type system, to parameterise State#. \begin{code} -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 [] PtrRep +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld \end{code} @@ -282,10 +272,10 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ \begin{code} -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName vrcsP PtrRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName vrcsZP PtrRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName vrcsZ PtrRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon @@ -300,7 +290,7 @@ mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] \end{code} @@ -312,7 +302,7 @@ mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] \end{code} @@ -324,7 +314,7 @@ mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] \end{code} @@ -336,7 +326,7 @@ mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP AddrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} @@ -348,7 +338,7 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ \begin{code} -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP PtrRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] \end{code} @@ -371,7 +361,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep %************************************************************************ \begin{code} -weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP PtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index ed7da33..e713eb7 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -195,13 +195,12 @@ funKindTyCon_RDR = nameRdrName funKindTyConName pcNonRecDataTyCon = pcTyCon False NonRecursive pcRecDataTyCon = pcTyCon False Recursive -pcTyCon is_enum is_rec name tyvars argvrcs cons +pcTyCon is_enum is_rec name tyvars cons = tycon where tycon = mkAlgTyCon name (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars - argvrcs [] -- No stupid theta (DataTyCon cons is_enum) [] -- No record selectors @@ -328,7 +327,7 @@ voidTy = unitTy \begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcNonRecDataTyCon charTyConName [] [] [charDataCon] +charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon] charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon stringTy = mkListTy charTy -- convenience only @@ -337,21 +336,21 @@ stringTy = mkListTy charTy -- convenience only \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon] +intTyCon = pcNonRecDataTyCon intTyConName [] [intDataCon] intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon \end{code} \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] +floatTyCon = pcNonRecDataTyCon floatTyConName [] [floatDataCon] floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] +doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon \end{code} @@ -408,7 +407,7 @@ primitive counterpart. boolTy = mkTyConTy boolTyCon boolTyCon = pcTyCon True NonRecursive boolTyConName - [] [] [falseDataCon, trueDataCon] + [] [falseDataCon, trueDataCon] falseDataCon = pcDataCon falseDataConName [] [] boolTyCon trueDataCon = pcDataCon trueDataConName [] [] boolTyCon @@ -436,8 +435,7 @@ data (,) a b = (,,) a b mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] -listTyCon = pcRecDataTyCon listTyConName - alpha_tyvar [(True,False)] [nilDataCon, consDataCon] +listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon consDataCon = pcDataConWithFixity True {- Declared infix -} @@ -525,7 +523,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty] -- `PrelPArr'. -- parrTyCon :: TyCon -parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [(True, False)] [parrDataCon] +parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 47231fb..bfec766 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -961,7 +961,7 @@ mkArbitraryType tv | otherwise = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $ - mkPrimTyCon tc_name kind 0 [] VoidRep + mkPrimTyCon tc_name kind 0 VoidRep -- Same name as the tyvar, apart from making it start with a colon (sigh) -- I dread to think what will happen if this gets out into an -- interface file. Catastrophe likely. Major sigh. diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a41ccbe..090db01 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -24,8 +24,8 @@ import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar ) -import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) + tcExtendRecEnv, tcLookupTyVar, InstInfo ) +import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, @@ -42,7 +42,7 @@ import Type ( splitTyConApp_maybe, import Kind ( mkArrowKinds, splitKindFunTys ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), +import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, @@ -111,9 +111,39 @@ Step 7: checkValidTyCl to check all the side conditions on validity. We could not do this before because we were in a mutually recursive knot. - +Identification of recursive TyCons +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to -@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. +@TyThing@s. + +Identifying a TyCon as recursive serves two purposes + +1. Avoid infinite types. Non-recursive newtypes are treated as +"transparent", like type synonyms, after the type checker. If we did +this for all newtypes, we'd get infinite types. So we figure out for +each newtype whether it is "recursive", and add a coercion if so. In +effect, we are trying to "cut the loops" by identifying a loop-breaker. + +2. Avoid infinite unboxing. This is nothing to do with newtypes. +Suppose we have + data T = MkT Int T + f (MkT x t) = f t +Well, this function diverges, but we don't want the strictness analyser +to diverge. But the strictness analyser will diverge because it looks +deeper and deeper into the structure of T. (I believe there are +examples where the function does something sane, and the strictness +analyser still diverges, but I can't see one now.) + +Now, concerning (1), the FC2 branch currently adds a coercion for ALL +newtypes. I did this as an experiment, to try to expose cases in which +the coercions got in the way of optimisations. If it turns out that we +can indeed always use a coercion, then we don't risk recursive types, +and don't need to figure out what the loop breakers are. + +For newtype *families* though, we will always have a coercion, so they +are always loop breakers! So you can easily adjust the current +algorithm by simply treating all newtype families as loop breakers (and +indeed type families). I think. \begin{code} tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] @@ -141,11 +171,10 @@ tcTyAndClassDecls boot_details decls -- Kind-check the declarations { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) - ; calc_rec = calcRecFlags boot_details rec_alg_tyclss - ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } + ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss + ; tc_decl = addLocM (tcTyClDecl calc_rec) } -- Type-check the type synonyms, and extend the envt - ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls + ; syn_tycons <- tcSynDecls kc_syn_decls ; tcExtendGlobalEnv syn_tycons $ do -- Type-check the data types and classes @@ -363,28 +392,27 @@ kcTyClDeclBody decl thing_inside %************************************************************************ \begin{code} -tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls calc_vrcs [] = return [] -tcSynDecls calc_vrcs (decl : decls) - = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls) +tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing] +tcSynDecls [] = return [] +tcSynDecls (decl : decls) + = do { syn_tc <- addLocM tcSynDecl decl + ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } -tcSynDecl calc_vrcs +tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) } + ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) } -------------------- -tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) - -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing -tcTyClDecl calc_vrcs calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) +tcTyClDecl calc_isrec decl + = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do @@ -420,19 +448,18 @@ tcTyClDecl1 calc_vrcs calc_isrec DataType -> mkDataTyConRhs data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) } where - arg_vrcs = calc_vrcs tc_name is_rec = calc_isrec tc_name h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False other -> True -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) @@ -447,10 +474,9 @@ tcTyClDecl1 calc_vrcs calc_isrec -- need to look up its recursiveness and variance tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name - tc_vrcs = calc_vrcs tycon_name in buildClass class_name tvs' ctxt' fds' - sig_stuff tc_isrec tc_vrcs) + sig_stuff tc_isrec) ; return (AClass clas) } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; @@ -458,9 +484,9 @@ tcTyClDecl1 calc_vrcs calc_isrec ; return (tvs1', tvs2') } -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) + = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 4ce5fed..f45af9e 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -2,9 +2,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 % -Analysis functions over data types. Specficially - a) detecting recursive types - b) computing argument variances +Analysis functions over data types. Specficially, detecting recursive types. This stuff is only used for source-code decls; it's recorded in interface files for imported data types. @@ -12,7 +10,6 @@ files for imported data types. \begin{code} module TcTyDecls( - calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) where @@ -24,9 +21,9 @@ import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep, tcView ) import HscTypes ( TyThing(..), ModDetails(..) ) -import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars, +import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars, synTyConDefn, isSynTyCon, isAlgTyCon, - tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs ) + tyConName, isNewTyCon, isProductTyCon, newTyConRhs ) import Class ( classTyCon ) import DataCon ( dataConOrigArgTys ) import Var ( TyVar ) @@ -320,154 +317,3 @@ tcTyConsOfType ty go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys \end{code} - - -%************************************************************************ -%* * - Compuing TyCon argument variances -%* * -%************************************************************************ - -Computing the tyConArgVrcs info -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each -tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed -separately. Note that this is information about occurrences of type -variables, not usages of term variables. - -The function @calcTyConArgVrcs@ must be passed a list of *algebraic or -syntycons only* such that all tycons referred to (by mutual recursion) -appear in the list. The fixpointing will be done on this set of -tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to -be (knot-tyingly?) stuck back into the appropriate fields. - -\begin{code} -calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs --- Gives arg variances for TyCons, --- including the class TyCon of a class -calcTyConArgVrcs tyclss - = get_vrc - where - tycons = map getTyCon tyclss - - -- We should only look up things that are in the map - get_vrc n = case lookupNameEnv final_oi n of - Just (_, pms) -> pms - Nothing -> pprPanic "calcVrcs" (ppr n) - - -- We are going to fold over this map, - -- so we need the TyCon in the range - final_oi :: NameEnv (TyCon, ArgVrcs) - final_oi = tcaoFix initial_oi - - initial_oi :: NameEnv (TyCon, ArgVrcs) - initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc)) - | tc <- tycons] - initial tc = replicate (tyConArity tc) (False,False) - - tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon - -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon - tcaoFix oi - | changed = tcaoFix oi' - | otherwise = oi' - where - (changed,oi') = foldNameEnv iterate (False,oi) oi - - iterate (tc, pms) (changed,oi') - = (changed || (pms /= pms'), - extendNameEnv oi' (tyConName tc) (tc, pms')) - where - pms' = tcaoIter oi' tc -- seq not simult - - tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial) - -> TyCon -- tycon to update - -> ArgVrcs -- new ArgVrcs for tycon - - tcaoIter oi tc | isAlgTyCon tc - = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs - where - data_cons = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig? - - tcaoIter oi tc | isSynTyCon tc - = let (tyvs,ty) = synTyConDefn tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> vrcInTy (lookup oi) v ty) tyvs - - lookup oi tc = case lookupNameEnv oi (tyConName tc) of - Just (_, pms) -> pms - Nothing -> tyConArgVrcs tc - -- We use the already-computed result for tycons not in this SCC -\end{code} - - -Variance of tyvars in a type -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A general variance-check function. We pass a function for determining -the @ArgVrc@s of a tycon; when fixpointing this refers to the current -value; otherwise this should be looked up from the tycon's own -tyConArgVrcs. Again, it knows the representation of Types. - -\begin{code} -vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) - -> TyVar -- tyvar to check Vrcs of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv - then vrcInTy fao v ty - else (False,False) - -- note that ftv cannot be calculated as occPos||occNeg, - -- since if a tyvar occurs only as unused tyconarg, - -- occPos==occNeg==False, but ftv=True - -vrcInTy fao v (TyVarTy v') = if v==v' - then (True,False) - else (False,False) - -vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) - then (True,True) - else vrcInTy fao v ty1 - -- ty1 is probably unknown (or it would have been beta-reduced); - -- hence if v occurs in ty2 at all then it could occur with - -- either variance. Otherwise it occurs as it does in ty1. - -vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) - `orVrc` - vrcInTy fao v ty2 - -vrcInTy fao v (ForAllTy v' ty) = if v==v' - then (False,False) - else vrcInTy fao v ty - -vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys - pms2 = fao tc - in orVrcs (zipWith timesVrc pms1 pms2) - -vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st) -\end{code} - -Variance algebra -~~~~~~~~~~~~~~~~ - -\begin{code} -orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) - -orVrcs :: [(Bool,Bool)] -> (Bool,Bool) -orVrcs = foldl orVrc (False,False) - -negVrc :: (Bool,Bool) -> (Bool,Bool) -negVrc (p1,m1) = (m1,p1) - -anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) -anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) - (False,False) as - -timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, - p1 && m2 || m1 && p2) -\end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index c80e3a7..fab15fc 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -5,7 +5,7 @@ \begin{code} module TyCon( - TyCon, ArgVrcs, FieldLabel, + TyCon, FieldLabel, PrimRep(..), tyConPrimRep, @@ -41,7 +41,6 @@ module TyCon( tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs, algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConStupidTheta, @@ -97,8 +96,6 @@ data TyCon tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon -- (b) the cached types in AlgTyConRhs.NewTyCon -- But not over the data constructors - argVrcs :: ArgVrcs, - algTcSelIds :: [Id], -- Its record selectors (empty if none): algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax @@ -138,10 +135,9 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: Type, -- Right-hand side, mentioning these type vars. + synTcRhs :: Type -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - argVrcs :: ArgVrcs } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -151,7 +147,6 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - argVrcs :: ArgVrcs, primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are @@ -182,9 +177,6 @@ type SuperKindCon = TyCon type FieldLabel = Name -type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- [] means "no information, assume the worst" - data AlgTyConRhs = AbstractTyCon -- We know nothing about this data type, except -- that it's represented by a pointer @@ -359,14 +351,13 @@ mkFunTyCon name kind -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs sel_ids is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - argVrcs = argvrcs, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, @@ -376,14 +367,13 @@ mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info gadt_syn hasGenerics = gen_info } -mkClassTyCon name kind tyvars argvrcs rhs clas is_rec +mkClassTyCon name kind tyvars rhs clas is_rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - argVrcs = argvrcs, algTcStupidTheta = [], algTcRhs = rhs, algTcSelIds = [], @@ -410,13 +400,12 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info -- as primitive, but *lifted*, TyCons for now. They are lifted -- because the Haskell type T representing the (foreign) .NET -- type T is actually implemented (in ILX) as a thunk -mkForeignTyCon name ext_name kind arity arg_vrcs +mkForeignTyCon name ext_name kind arity = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - argVrcs = arg_vrcs, primTyConRep = PtrRep, -- they all do isUnLifted = False, tyConExtName = ext_name @@ -424,37 +413,35 @@ mkForeignTyCon name ext_name kind arity arg_vrcs -- most Prim tycons are lifted -mkPrimTyCon name kind arity arg_vrcs rep - = mkPrimTyCon' name kind arity arg_vrcs rep True +mkPrimTyCon name kind arity rep + = mkPrimTyCon' name kind arity rep True -mkVoidPrimTyCon name kind arity arg_vrcs - = mkPrimTyCon' name kind arity arg_vrcs VoidRep True +mkVoidPrimTyCon name kind arity + = mkPrimTyCon' name kind arity VoidRep True -- but RealWorld is lifted -mkLiftedPrimTyCon name kind arity arg_vrcs rep - = mkPrimTyCon' name kind arity arg_vrcs rep False +mkLiftedPrimTyCon name kind arity rep + = mkPrimTyCon' name kind arity rep False -mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted +mkPrimTyCon' name kind arity rep is_unlifted = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - argVrcs = arg_vrcs, primTyConRep = rep, isUnLifted = is_unlifted, tyConExtName = Nothing } -mkSynTyCon name kind tyvars rhs argvrcs +mkSynTyCon name kind tyvars rhs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - synTcRhs = rhs, - argVrcs = argvrcs + synTcRhs = rhs } mkCoercionTyCon name arity kindRule @@ -711,19 +698,6 @@ tyConStupidTheta (TupleTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} -@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for -each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is -actually computed (in another file). - -\begin{code} -tyConArgVrcs :: TyCon -> ArgVrcs -tyConArgVrcs (FunTyCon {}) = [(False,True),(True,False)] -tyConArgVrcs (AlgTyCon {argVrcs = oi}) = oi -tyConArgVrcs (PrimTyCon {argVrcs = oi}) = oi -tyConArgVrcs (TupleTyCon {tyConArity = arity}) = (replicate arity (True,False)) -tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi -\end{code} - \begin{code} synTyConDefn :: TyCon -> ([TyVar], Type) synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty) diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 5625f8e..cef77a1 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -324,7 +324,7 @@ eqCoercionKindTyCon = mkCoercionTyCon eqCoercionKindTyConName 2 (\ _ -> coSuperKind) mkKindTyCon :: Name -> TyCon -mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 [] +mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 -------------------------- -- ... and now their names -- 1.7.10.4