Commit b8b3e30a authored by Edward Z. Yang's avatar Edward Z. Yang

Axe RecFlag on TyCons.

Summary:
This commit removes the information about whether or not
a TyCon is "recursive", as well as the code responsible
for calculating this information.

The original trigger for this change was complexity regarding
how we computed the RecFlag for hs-boot files.  The problem
is that in order to determine if a TyCon is recursive or
not, we need to determine if it was defined in an hs-boot
file (if so, we conservatively assume that it is recursive.)

It turns that doing this is quite tricky.  The "obvious"
strategy is to typecheck the hi-boot file (since we are
eventually going to need the typechecked types to check
if we properly implemented the hi-boot file) and just extract
the names of all defined TyCons from the ModDetails, but
this actually does not work well if Names from the hi-boot
file are being knot-tied via if_rec_types: the "extraction"
process will force thunks, which will force the typechecking
process earlier than we have actually defined the types
locally.

Rather than work around all this trickiness (it certainly
can be worked around, either by making interface loading
MORE lazy, or just reading of the set of defined TyCons
directly from the ModIface), we instead opted to excise
the source of the problem, the RecFlag.

For one, it is not clear if the RecFlag even makes sense,
in the presence of higher-orderness:

    data T f a = MkT (f a)

T doesn't look recursive, but if we instantiate f with T,
then it very well is!  It was all very shaky.

So we just don't bother anymore.  This has two user-visible
implications:

1. is_too_recursive now assumes that all TyCons are
recursive and will bail out in a way that is still mysterious
to me if there are too many TyCons.

2. checkRecTc, which is used when stripping newtypes to
get to representation, also assumes all TyCons are
recursive, and will stop running if we hit the limit.

The biggest risk for this patch is that we specialize less
than we used to; however, the codeGen tests still seem to
be passing.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Reviewers: simonpj, austin, bgamari

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2360
parent 480e0661
......@@ -1283,14 +1283,13 @@ buildAlgTyCon :: Name
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> was declared in GADT syntax
-> AlgTyConFlav
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec gadt_syn parent
gadt_syn parent
= mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
rhs parent is_rec gadt_syn
rhs parent gadt_syn
where
binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
......@@ -285,11 +285,10 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
-> ClassMinimalDef -- Minimal complete definition
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
buildClass tycon_name binders roles sc_theta
fds at_items sig_stuff mindef tc_isrec
fds at_items sig_stuff mindef
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
......@@ -356,7 +355,7 @@ buildClass tycon_name binders roles sc_theta
else return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name binders roles
rhs rec_clas tc_isrec tc_rep_name
rhs rec_clas tc_rep_name
-- 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 }
......
......@@ -101,7 +101,6 @@ data IfaceDecl
ifRoles :: [Role], -- Roles
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
ifRec :: RecFlag, -- Recursive or not?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifParent :: IfaceTyConParent -- The axiom, for a newtype,
......@@ -130,9 +129,7 @@ data IfaceDecl
ifFDs :: [FunDep FastString], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
ifMinDef :: BooleanFormula IfLclName, -- Minimal complete definition
ifRec :: RecFlag -- Is newtype/datatype associated
-- with the class recursive?
ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
}
| IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name
......@@ -625,7 +622,7 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ifCtxt = context,
ifRoles = roles, ifCons = condecls,
ifParent = parent, ifRec = isrec,
ifParent = parent,
ifGadtSyntax = gadt,
ifBinders = binders })
......@@ -671,10 +668,10 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
IfDataTyCon{} -> text "data"
IfNewTyCon{} -> text "newtype"
pp_extra = vcat [pprCType ctype, pprRec isrec]
pp_extra = vcat [pprCType ctype]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs
, ifCtxt = context, ifName = clas
, ifRoles = roles
, ifFDs = fds, ifMinDef = minDef
......@@ -682,14 +679,13 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
= vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles
, text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
<+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs, pprec
, nest 2 (vcat [ vcat asocs, vcat dsigs
, ppShowAllSubs ss (pprMinDef minDef)])]
where
pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
asocs = ppr_trim $ map maybeShowAssoc ats
dsigs = ppr_trim $ map maybeShowSig sigs
pprec = ppShowIface ss (pprRec isrec)
maybeShowAssoc :: IfaceAT -> Maybe SDoc
maybeShowAssoc asc@(IfaceAT d _)
......@@ -805,10 +801,6 @@ pprRoles suppress_if tyCon bndrs roles
in ppUnless (all suppress_if roles || null froles) $
text "type role" <+> tyCon <+> hsep (map ppr froles)
pprRec :: RecFlag -> SDoc
pprRec NonRecursive = Outputable.empty
pprRec Recursive = text "RecFlag: Recursive"
pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc
pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
= pprInfixVar (isSymOcc occ) (ppr_bndr occ)
......@@ -1453,7 +1445,7 @@ instance Binary IfaceDecl where
put_ bh details
put_ bh idinfo
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
......@@ -1464,7 +1456,6 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh a10
put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
putByte bh 3
......@@ -1483,7 +1474,7 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 5
put_ bh a1
put_ bh (occNameFS a2)
......@@ -1493,7 +1484,6 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 6
......@@ -1535,9 +1525,8 @@ instance Binary IfaceDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
a10 <- get bh
occ <- return $! mkTcOccFS a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
3 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
......@@ -1561,9 +1550,8 @@ instance Binary IfaceDecl where
a6 <- get bh
a7 <- get bh
a8 <- get bh
a9 <- get bh
occ <- return $! mkClsOccFS a2
return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8)
6 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
......
......@@ -1409,7 +1409,6 @@ tyConToIfaceDecl env tycon
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifParent = parent })
......@@ -1425,7 +1424,6 @@ tyConToIfaceDecl env tycon
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [] False [],
ifRec = boolToRecFlag False,
ifGadtSyntax = False,
ifParent = IfNoParent })
where
......@@ -1526,8 +1524,7 @@ classToIfaceDecl env clas
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getOccFS (classMinimalDef clas),
ifRec = boolToRecFlag (isRecursiveTyCon tycon) })
ifMinDef = fmap getOccFS (classMinimalDef clas) })
where
(_, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig clas
......
......@@ -320,7 +320,7 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec, ifParent = mb_parent })
ifParent = mb_parent })
= bindIfaceTyConBinders_AT binders $ \ binders' -> do
{ tc_name <- lookupIfaceTop occ_name
; res_kind' <- tcIfaceType res_kind
......@@ -331,7 +331,7 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
; return (mkAlgTyCon tc_name binders' res_kind'
roles cType stupid_theta
cons parent' is_rec gadt_syn) }
cons parent' gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
......@@ -397,7 +397,7 @@ tc_iface_decl _parent ignore_prags
ifBinders = binders,
ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ, ifRec = tc_isrec })
ifMinDef = mindef_occ })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
= bindIfaceTyConBinders binders $ \ binders' -> do
......@@ -412,7 +412,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass tc_name binders' roles ctxt fds ats sigs mindef tc_isrec }
; buildClass tc_name binders' roles ctxt fds ats sigs mindef }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
......
......@@ -136,7 +136,7 @@ import Class ( Class, mkClass )
import RdrName
import Name
import NameSet ( NameSet, mkNameSet, elemNameSet )
import BasicTypes ( Arity, RecFlag(..), Boxity(..),
import BasicTypes ( Arity, Boxity(..),
TupleSort(..) )
import ForeignCall
import SrcLoc ( noSrcSpan )
......@@ -446,14 +446,14 @@ parrTyCon_RDR = nameRdrName parrTyConName
************************************************************************
-}
pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcNonEnumTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-- Not an enumeration
pcNonRecDataTyCon = pcTyCon False NonRecursive
pcNonEnumTyCon = pcTyCon False
-- This function assumes that the types it creates have all parameters at
-- Representational role, and that there is no kind polymorphism.
pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec name cType tyvars cons
pcTyCon :: Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum name cType tyvars cons
= mkAlgTyCon name
(mkAnonTyConBinders tyvars)
liftedTypeKind
......@@ -462,7 +462,6 @@ pcTyCon is_enum is_rec name cType tyvars cons
[] -- No stupid theta
(DataTyCon cons is_enum)
(VanillaAlgTyCon (mkPrelTyConRepName name))
is_rec
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
......@@ -535,15 +534,15 @@ pcSpecialDataCon dc_name arg_tys tycon rri
typeNatKindCon, typeSymbolKindCon :: TyCon
-- data Nat
-- data Symbol
typeNatKindCon = pcTyCon False NonRecursive typeNatKindConName Nothing [] []
typeSymbolKindCon = pcTyCon False NonRecursive typeSymbolKindConName Nothing [] []
typeNatKindCon = pcTyCon False typeNatKindConName Nothing [] []
typeSymbolKindCon = pcTyCon False typeSymbolKindConName Nothing [] []
typeNatKind, typeSymbolKind :: Kind
typeNatKind = mkTyConTy typeNatKindCon
typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon False NonRecursive constraintKindTyConName
constraintKindTyCon = pcTyCon False constraintKindTyConName
Nothing [] []
liftedTypeKind, constraintKind, unboxedTupleKind :: Kind
......@@ -826,7 +825,7 @@ heqSCSelId, coercibleSCSelId :: Id
= (tycon, klass, datacon, sc_sel_id)
where
tycon = mkClassTyCon heqTyConName binders roles
rhs klass NonRecursive
rhs klass
(mkPrelTyConRepName heqTyConName)
klass = mk_class tycon sc_pred sc_sel_id
datacon = pcDataCon heqDataConName tvs [sc_pred] tycon
......@@ -844,7 +843,7 @@ heqSCSelId, coercibleSCSelId :: Id
= (tycon, klass, datacon, sc_sel_id)
where
tycon = mkClassTyCon coercibleTyConName binders roles
rhs klass NonRecursive
rhs klass
(mkPrelTyConRepName coercibleTyConName)
klass = mk_class tycon sc_pred sc_sel_id
datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon
......@@ -890,7 +889,7 @@ unicodeStarKindTyCon = mkSynonymTyCon unicodeStarKindTyConName
(tYPE ptrRepLiftedTy)
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcNonRecDataTyCon runtimeRepTyConName Nothing []
runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing []
(vecRepDataCon : runtimeRepSimpleDataCons)
vecRepDataCon :: DataCon
......@@ -935,7 +934,7 @@ voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
runtimeRepSimpleDataCons
vecCountTyCon :: TyCon
vecCountTyCon = pcNonRecDataTyCon vecCountTyConName Nothing []
vecCountTyCon = pcNonEnumTyCon vecCountTyConName Nothing []
vecCountDataCons
-- See Note [Wiring in RuntimeRep]
......@@ -954,7 +953,7 @@ vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons
vecElemTyCon :: TyCon
vecElemTyCon = pcNonRecDataTyCon vecElemTyConName Nothing [] vecElemDataCons
vecElemTyCon = pcNonEnumTyCon vecElemTyConName Nothing [] vecElemDataCons
-- See Note [Wiring in RuntimeRep]
vecElemDataCons :: [DataCon]
......@@ -992,7 +991,7 @@ charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
charTyCon = pcNonRecDataTyCon charTyConName
charTyCon = pcNonEnumTyCon charTyConName
(Just (CType "" Nothing ("HsChar",fsLit "HsChar")))
[] [charDataCon]
charDataCon :: DataCon
......@@ -1005,7 +1004,7 @@ intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
intTyCon = pcNonRecDataTyCon intTyConName
intTyCon = pcNonEnumTyCon intTyConName
(Just (CType "" Nothing ("HsInt",fsLit "HsInt"))) []
[intDataCon]
intDataCon :: DataCon
......@@ -1015,7 +1014,7 @@ wordTy :: Type
wordTy = mkTyConTy wordTyCon
wordTyCon :: TyCon
wordTyCon = pcNonRecDataTyCon wordTyConName
wordTyCon = pcNonEnumTyCon wordTyConName
(Just (CType "" Nothing ("HsWord", fsLit "HsWord"))) []
[wordDataCon]
wordDataCon :: DataCon
......@@ -1025,7 +1024,7 @@ word8Ty :: Type
word8Ty = mkTyConTy word8TyCon
word8TyCon :: TyCon
word8TyCon = pcNonRecDataTyCon word8TyConName
word8TyCon = pcNonEnumTyCon word8TyConName
(Just (CType "" Nothing ("HsWord8", fsLit "HsWord8"))) []
[word8DataCon]
word8DataCon :: DataCon
......@@ -1035,7 +1034,7 @@ floatTy :: Type
floatTy = mkTyConTy floatTyCon
floatTyCon :: TyCon
floatTyCon = pcNonRecDataTyCon floatTyConName
floatTyCon = pcNonEnumTyCon floatTyConName
(Just (CType "" Nothing ("HsFloat", fsLit "HsFloat"))) []
[floatDataCon]
floatDataCon :: DataCon
......@@ -1045,7 +1044,7 @@ doubleTy :: Type
doubleTy = mkTyConTy doubleTyCon
doubleTyCon :: TyCon
doubleTyCon = pcNonRecDataTyCon doubleTyConName
doubleTyCon = pcNonEnumTyCon doubleTyConName
(Just (CType "" Nothing ("HsDouble",fsLit "HsDouble"))) []
[doubleDataCon]
......@@ -1106,7 +1105,7 @@ boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
boolTyCon = pcTyCon True NonRecursive boolTyConName
boolTyCon = pcTyCon True boolTyConName
(Just (CType "" Nothing ("HsBool", fsLit "HsBool")))
[] [falseDataCon, trueDataCon]
......@@ -1119,7 +1118,7 @@ falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
orderingTyCon :: TyCon
orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing
orderingTyCon = pcTyCon True orderingTyConName Nothing
[] [ltDataCon, eqDataCon, gtDataCon]
ltDataCon, eqDataCon, gtDataCon :: DataCon
......@@ -1151,7 +1150,7 @@ listTyCon :: TyCon
listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
Nothing []
(DataTyCon [nilDataCon, consDataCon] False )
Recursive False
False
(VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
nilDataCon :: DataCon
......@@ -1168,7 +1167,7 @@ consDataCon = pcDataConWithFixity True {- Declared infix -}
-- Wired-in type Maybe
maybeTyCon :: TyCon
maybeTyCon = pcTyCon False NonRecursive maybeTyConName Nothing alpha_tyvar
maybeTyCon = pcTyCon False maybeTyConName Nothing alpha_tyvar
[nothingDataCon, justDataCon]
nothingDataCon :: DataCon
......@@ -1264,7 +1263,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty]
-- @PrelPArr@.
--
parrTyCon :: TyCon
parrTyCon = pcNonRecDataTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]
parrTyCon = pcNonEnumTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]
parrDataCon :: DataCon
parrDataCon = pcDataCon
......
......@@ -34,7 +34,7 @@ import DataCon
import Coercion hiding( substCo )
import Rules
import Type hiding ( substTy )
import TyCon ( isRecursiveTyCon, tyConName )
import TyCon ( tyConName )
import Id
import PprCore ( pprParendExpr )
import MkCore ( mkImpossibleExpr )
......@@ -1834,15 +1834,15 @@ is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool
-- This is only necessary if ForceSpecConstr is in effect:
-- otherwise specConstrCount will cause specialisation to terminate.
-- See Note [Limit recursive specialisation]
-- TODO: make me more accurate
is_too_recursive env ((_,exprs), val_env)
= sc_force env && maximum (map go exprs) > sc_recursive env
where
go e
| Just (ConVal (DataAlt dc) args) <- isValue val_env e
, isRecursiveTyCon (dataConTyCon dc)
| Just (ConVal (DataAlt _) args) <- isValue val_env e
= 1 + sum (map go args)
|App f a <- e
| App f a <- e
= go f + go a
| otherwise
......
......@@ -671,7 +671,7 @@ tcDataFamInstDecl mb_clsinfo
(map (const Nominal) full_tvs)
(fmap unLoc cType) stupid_theta
tc_rhs parent
Recursive gadt_syntax
gadt_syntax
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
......
......@@ -185,9 +185,7 @@ tcTyClDecls tyclds role_annots
-- the final TyCons and Classes
; fixM $ \ ~rec_tyclss -> do
{ is_boot <- tcIsHsBootOrSig
; self_boot <- tcSelfBootInfo
; let rec_flags = calcRecFlags self_boot is_boot
role_annots rec_tyclss
; let roles = inferRoles is_boot role_annots rec_tyclss
-- Populate environment with knot-tied ATyCon for TyCons
-- NB: if the decls mention any ill-staged data cons
......@@ -201,7 +199,7 @@ tcTyClDecls tyclds role_annots
tcExtendKindEnv2 (map mkTcTyConPair tc_tycons) $
-- Kind and type check declarations for this group
mapM (tcTyClDecl rec_flags) tyclds
mapM (tcTyClDecl roles) tyclds
} }
where
ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
......@@ -706,8 +704,8 @@ e.g. the need to make the data constructor worker name for
a constraint tuple match the wired-in one
-}
tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM TyCon
tcTyClDecl rec_info (L loc decl)
tcTyClDecl :: RolesInfo -> LTyClDecl Name -> TcM TyCon
tcTyClDecl roles_info (L loc decl)
| Just thing <- wiredInNameTyThing_maybe (tcdName decl)
= case thing of -- See Note [Declarations for wired-in things]
ATyCon tc -> return tc
......@@ -716,28 +714,28 @@ tcTyClDecl rec_info (L loc decl)
| otherwise
= setSrcSpan loc $ tcAddDeclCtxt decl $
do { traceTc "tcTyAndCl-x" (ppr decl)
; tcTyClDecl1 Nothing rec_info decl }
; tcTyClDecl1 Nothing roles_info decl }
-- "type family" declarations
tcTyClDecl1 :: Maybe Class -> RecTyInfo -> TyClDecl Name -> TcM TyCon
tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl Name -> TcM TyCon
tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })
= tcFamDecl1 parent fd
-- "type" synonym declaration
tcTyClDecl1 _parent rec_info
tcTyClDecl1 _parent roles_info
(SynDecl { tcdLName = L _ tc_name, tcdRhs = rhs })
= ASSERT( isNothing _parent )
tcTyClTyVars tc_name $ \ binders res_kind ->
tcTySynRhs rec_info tc_name binders res_kind rhs
tcTySynRhs roles_info tc_name binders res_kind rhs
-- "data/newtype" declaration
tcTyClDecl1 _parent rec_info
tcTyClDecl1 _parent roles_info
(DataDecl { tcdLName = L _ tc_name, tcdDataDefn = defn })
= ASSERT( isNothing _parent )
tcTyClTyVars tc_name $ \ tycon_binders res_kind ->
tcDataDefn rec_info tc_name tycon_binders res_kind defn
tcDataDefn roles_info tc_name tycon_binders res_kind defn
tcTyClDecl1 _parent rec_info
tcTyClDecl1 _parent roles_info
(ClassDecl { tcdLName = L _ class_name
, tcdCtxt = ctxt, tcdMeths = meths
, tcdFDs = fundeps, tcdSigs = sigs
......@@ -751,8 +749,7 @@ tcTyClDecl1 _parent rec_info
-- need to look up its recursiveness
; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
; let tycon_name = tyConName (classTyCon clas)
tc_isrec = rti_is_rec rec_info tycon_name
roles = rti_roles rec_info tycon_name
roles = roles_info tycon_name
; ctxt' <- solveEqualities $ tcHsContext ctxt
; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'
......@@ -764,7 +761,7 @@ tcTyClDecl1 _parent rec_info
; clas <- buildClass
class_name binders roles ctxt'
fds' at_stuff
sig_stuff mindef tc_isrec
sig_stuff mindef
; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
ppr fds')
; return clas }
......@@ -905,31 +902,31 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))
, ppr inj_ktvs, ppr inj_bools ])
; return $ Injective inj_bools }
tcTySynRhs :: RecTyInfo
tcTySynRhs :: RolesInfo
-> Name
-> [TyConBinder] -> Kind
-> LHsType Name -> TcM TyCon
tcTySynRhs rec_info tc_name binders res_kind hs_ty
tcTySynRhs roles_info tc_name binders res_kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let roles = rti_roles rec_info tc_name
; let roles = roles_info tc_name
tycon = mkSynonymTyCon tc_name binders res_kind roles rhs_ty
; return tycon }
tcDataDefn :: RecTyInfo -> Name
tcDataDefn :: RolesInfo -> Name
-> [TyConBinder] -> Kind
-> HsDataDefn Name -> TcM TyCon
-- NB: not used for newtype/data instances (whether associated or not)
tcDataDefn rec_info -- Knot-tied; don't look at this eagerly
tcDataDefn roles_info
tc_name tycon_binders res_kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
, dd_cons = cons })
= do { (extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
; let final_bndrs = tycon_binders `chkAppend` extra_bndrs
roles = rti_roles rec_info tc_name
roles = roles_info tc_name
; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt
; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv
......@@ -956,7 +953,6 @@ tcDataDefn rec_info -- Knot-tied; don't look at this eagerly
(fmap unLoc cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
(rti_is_rec rec_info tc_name)
gadt_syntax) }
; return tycon }
where
......
......@@ -12,7 +12,8 @@ files for imported data types.
{-# LANGUAGE CPP #-}
module TcTyDecls(
calcRecFlags, RecTyInfo(..),
RolesInfo,
inferRoles,
calcSynCycles,
checkClassCycles,
......@@ -47,8 +48,7 @@ import Id
import IdInfo
import VarEnv
import VarSet
import NameSet ( NameSet, unitNameSet, emptyNameSet, unionNameSet
, extendNameSet, mkNameSet, elemNameSet )
import NameSet ( NameSet, unitNameSet, extendNameSet, elemNameSet )
import Coercion ( ltRole )
import Digraph
import BasicTypes
......@@ -57,7 +57,6 @@ import Unique ( mkBuiltinUnique )
import Outputable
import Util
import Maybes
import Data.List
import Bag
import FastString
import FV
......@@ -250,231 +249,6 @@ checkClassCycles cls
where
cls_nm = getName cls
{-
************************************************************************
* *
Deciding which type constructors are recursive
* *
************************************************************************
Identification of recursive TyCons
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@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 has 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.)