Commit 0a882747 authored by batterseapower's avatar batterseapower

Simplified serialization of IfaceTyCon, again

Jose's patch implementing kind-polymorphic core (09015be8) reverted many of the simplifying changes to interface file TyCon serialization I had made in a previous patch (5d7173f9). Based on the diff I think this was an unintended consequence of how Jose did the merge rather than a real change he intended to make.

In fact, as a result of kind-polymorphic core we don't need to treat the Any TyCon specially any longer so my old simplifying changes can be made even simpler: IfaceTyCon is now just a newtype on IfaceExtName.
parent d7d6c42a
......@@ -998,33 +998,10 @@ instance Binary IfaceType where
putByte bh 3
put_ bh ag
put_ bh ah
-- Simple compression for common cases of TyConApp
put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
-- Unit tuple and pairs
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2])
= do { putByte bh 11; put_ bh t1; put_ bh t2 }
-- Kind cases
put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17
put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18
put_ bh (IfaceCoConApp cc tys)
= do { putByte bh 19; put_ bh cc; put_ bh tys }
-- Generic cases
put_ bh (IfaceTyConApp (IfaceTc tc) tys)
= do { putByte bh 20; put_ bh tc; put_ bh tys }
= do { putByte bh 4; put_ bh cc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 21; put_ bh tc; put_ bh tys }
= do { putByte bh 5; put_ bh tc; put_ bh tys }
get bh = do
h <- getByte bh
......@@ -1040,70 +1017,16 @@ instance Binary IfaceType where
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
-- Now the special cases for TyConApp
6 -> return (IfaceTyConApp IfaceIntTc [])
7 -> return (IfaceTyConApp IfaceCharTc [])
8 -> return (IfaceTyConApp IfaceBoolTc [])
9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
11 -> do { t1 <- get bh; t2 <- get bh
; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
17 -> return (IfaceTyConApp IfaceConstraintKindTc [])
18 -> return (IfaceTyConApp IfaceSuperKindTc [])
19 -> do { cc <- get bh; tys <- get bh
; return (IfaceCoConApp cc tys) }
20 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp (IfaceTc tc) tys) }
21 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
4 -> do { cc <- get bh; tys <- get bh
; return (IfaceCoConApp cc tys) }
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
_ -> panic ("get IfaceType " ++ show h)
instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated
put_ bh IfaceIntTc = putByte bh 1
put_ bh IfaceBoolTc = putByte bh 2
put_ bh IfaceCharTc = putByte bh 3
put_ bh IfaceListTc = putByte bh 4
put_ bh IfacePArrTc = putByte bh 5
put_ bh IfaceLiftedTypeKindTc = putByte bh 6
put_ bh IfaceOpenTypeKindTc = putByte bh 7
put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
put_ bh IfaceUbxTupleKindTc = putByte bh 9
put_ bh IfaceArgTypeKindTc = putByte bh 10
put_ bh IfaceConstraintKindTc = putByte bh 11
put_ bh IfaceSuperKindTc = putByte bh 12
put_ bh (IfaceTupTc bx ar) = do { putByte bh 13; put_ bh bx; put_ bh ar }
put_ bh (IfaceTc ext) = do { putByte bh 14; put_ bh ext }
put_ bh (IfaceIPTc n) = do { putByte bh 15; put_ bh n }
get bh = do
h <- getByte bh
case h of
1 -> return IfaceIntTc
2 -> return IfaceBoolTc
3 -> return IfaceCharTc
4 -> return IfaceListTc
5 -> return IfacePArrTc
6 -> return IfaceLiftedTypeKindTc
7 -> return IfaceOpenTypeKindTc
8 -> return IfaceUnliftedTypeKindTc
9 -> return IfaceUbxTupleKindTc
10 -> return IfaceArgTypeKindTc
11 -> return IfaceConstraintKindTc
12 -> return IfaceSuperKindTc
13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
14 -> do { ext <- get bh; return (IfaceTc ext) }
15 -> do { n <- get bh; return (IfaceIPTc n) }
_ -> panic ("get IfaceTyCon " ++ show h)
put_ bh (IfaceTc ext) = put_ bh ext
get bh = liftM IfaceTc (get bh)
instance Binary IfaceCoCon where
put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
......
......@@ -882,7 +882,6 @@ freeNamesIfExpr _ = emptyNameSet
freeNamesIfTc :: IfaceTyCon -> NameSet
freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfTc _ = emptyNameSet
freeNamesIfCo :: IfaceCoCon -> NameSet
freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
......
......@@ -18,7 +18,6 @@ module IfaceType (
IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
-- Conversion from Type -> IfaceType
toIfaceType, toIfaceKind, toIfaceContext,
......@@ -87,20 +86,9 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyCon -- Encodes type constructors, kind constructors
-- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc TupleSort Arity
| IfaceIPTc IfIPName -- Used for implicit parameter TyCons
-- Kind constructors
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc
-- SuperKind constructor
| IfaceSuperKindTc -- IA0_NOTE: You might want to check if I didn't forget something.
-- Encodes type constructors, kind constructors
-- coercion constructors, the lot
newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
-- Coercion constructors
data IfaceCoCon
......@@ -109,40 +97,8 @@ data IfaceCoCon
| IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
| IfaceTransCo | IfaceInstCo
| IfaceNthCo Int
ifaceTyConName :: IfaceTyCon -> Name
ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
ifaceTyConName IfaceListTc = listTyConName
ifaceTyConName IfacePArrTc = parrTyConName
ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar)
ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName
ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName
ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName
ifaceTyConName IfaceSuperKindTc = superKindTyConName
ifaceTyConName (IfaceTc ext) = ext
ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n)
-- Note [The Name of an IfaceAnyTc]
\end{code}
Note [The Name of an IfaceAnyTc]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
IA0_NOTE: This is an old comment. It needs to be updated with IPTc which
I don't know about.
It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you
really need to do is to transform it to a TyCon, and get the Name of that.
But doing so needs the monad because there's an IfaceKind inside, and we
need a Kind.
In fact, ifaceTyConName is only used for instances and rules, and we don't
expect to instantiate those at these (internal-ish) Any types, so rather
than solve this potential problem now, I'm going to defer it until it happens!
%************************************************************************
%* *
Functions over IFaceTypes
......@@ -214,9 +170,10 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc [])
= ppr tv
pprIfaceTvBndr (tv, IfaceTyConApp tc [])
| ifaceTyConName tc == liftedTypeKindTyConName = ppr tv
pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars)
\end{code}
......@@ -280,32 +237,29 @@ pprIfaceForAllPart tvs ctxt doc
ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
ppr_tc_app _ tc [] = ppr_tc tc
ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc"
ppr_tc_app _ IfacePArrTc [ty] = paBrackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc"
ppr_tc_app _ (IfaceTupTc sort _) tys =
tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
ppr_tc_app _ (IfaceIPTc n) [ty] =
parens (ppr n <> dcolon <> pprIfaceType ty)
ppr_tc_app _ (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc"
ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty)
ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = paBrackets (pprIfaceType ty)
ppr_tc_app _ (IfaceTc n) tys
| Just (ATyCon tc) <- wiredInNameTyThing_maybe n
, Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
= tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
| Just (ATyCon tc) <- wiredInNameTyThing_maybe n
, Just ip <- tyConIP_maybe tc
, [ty] <- tys
= parens (ppr ip <> dcolon <> pprIfaceType ty)
ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
ppr_tc :: IfaceTyCon -> SDoc
-- Wrap infix type constructors in parens
ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc)
ppr_tc tc = ppr tc
ppr_tc tc = parenSymOcc (getOccName (ifaceTyConName tc)) (ppr tc)
-------------------
instance Outputable IfaceTyCon where
ppr (IfaceIPTc n) = ppr (IPName n)
ppr other_tc = ppr (ifaceTyConName other_tc)
ppr = ppr . ifaceTyConName
instance Outputable IfaceCoCon where
ppr (IfaceCoAx n) = ppr n
......@@ -368,35 +322,10 @@ toIfaceCoVar = occNameFS . getOccName
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
| isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
| Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
| otherwise = toIfaceTyCon_name (tyConName tc)
toIfaceTyCon = toIfaceTyCon_name . tyConName
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name nm
| Just (ATyCon tc) <- wiredInNameTyThing_maybe nm
= toIfaceWiredInTyCon tc nm
| otherwise
= IfaceTc nm
toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
toIfaceWiredInTyCon tc nm
| isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
| Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
| nm == intTyConName = IfaceIntTc
| nm == boolTyConName = IfaceBoolTc
| nm == charTyConName = IfaceCharTc
| nm == listTyConName = IfaceListTc
| nm == parrTyConName = IfacePArrTc
| nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc
| nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc
| nm == openTypeKindTyConName = IfaceOpenTypeKindTc
| nm == argTypeKindTyConName = IfaceArgTypeKindTc
| nm == constraintKindTyConName = IfaceConstraintKindTc
| nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc
| nm == superKindTyConName = IfaceSuperKindTc
| otherwise = IfaceTc nm
toIfaceTyCon_name = IfaceTc
----------------
toIfaceTypes :: [Type] -> [IfaceType]
......
......@@ -41,7 +41,7 @@ import TyCon
import DataCon
import PrelNames
import TysWiredIn
import TysPrim ( superKindTyCon )
import TysPrim ( superKindTyConName )
import BasicTypes ( Arity, strongLoopBreaker )
import Literal
import qualified Var
......@@ -1236,6 +1236,9 @@ tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
-- Wired-in things include TyCons, DataCons, and Ids
-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this thing (particularly TyCon) are loaded
-- Imagine: f :: Double -> Double
= do { ifCheckWiredInThing thing; return thing }
| otherwise
= do { env <- getGblEnv
......@@ -1280,37 +1283,8 @@ tcIfaceGlobal name
-- emasculated form (e.g. lacking data constructors).
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon
tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon
tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n
; tcWiredInTyCon (ipTyCon n') }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
check_tc tc
| debugIsOn = case toIfaceTyCon tc of
IfaceTc _ -> tc
_ -> pprTrace "check_tc" (ppr tc) tc
| otherwise = tc
-- we should be okay just returning Kind constructors without extra loading
tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon
tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon
tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon
tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon
tcIfaceTyCon IfaceSuperKindTc = return superKindTyCon
-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc)
; return tc }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (tyThingTyCon thing) }
tcIfaceCoAxiom :: Name -> IfL CoAxiom
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
......@@ -1382,7 +1356,7 @@ bindIfaceTyVars bndrs thing_inside
(occs,kinds) = unzip bndrs
isSuperIfaceKind :: IfaceKind -> Bool
isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True
isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
isSuperIfaceKind _ = False
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
......
......@@ -1616,25 +1616,6 @@ mzipIdKey = mkPreludeMiscIdUnique 196
-----------------------------------------------------
\end{code}
%************************************************************************
%* *
\subsection{Standard groups of types}
%* *
%************************************************************************
\begin{code}
kindKeys :: [Unique]
kindKeys = [ anyKindTyConKey
, liftedTypeKindTyConKey
, openTypeKindTyConKey
, unliftedTypeKindTyConKey
, ubxTupleKindTyConKey
, argTypeKindTyConKey
, constraintKindTyConKey ]
\end{code}
%************************************************************************
%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
......
......@@ -131,7 +131,6 @@ primTyCons
, word32PrimTyCon
, word64PrimTyCon
, anyTyCon
, anyKindTyCon
, eqPrimTyCon
, liftedTypeKindTyCon
......@@ -140,6 +139,8 @@ primTyCons
, argTypeKindTyCon
, ubxTupleKindTyCon
, constraintKindTyCon
, superKindTyCon
, anyKindTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment