Commit 3e0b6b25 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Remove argument variance info of tycons

Fri Aug 11 13:53:24 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * 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.           **
parent 839a0880
......@@ -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
......
......@@ -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 }
......
......@@ -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) &&&
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -2,9 +2,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
%