Commit 91c6b1f5 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Generate Typeable info at definition sites

This is the second attempt at merging D757.

This patch implements the idea floated in Trac #9858, namely that we
should generate type-representation information at the data type
declaration site, rather than when solving a Typeable constraint.

However, this turned out quite a bit harder than I expected. I still
think it's the right thing to do, and it's done now, but it was quite
a struggle.

See particularly

 * Note [Grand plan for Typeable] in TcTypeable (which is a new module)
 * Note [The overall promotion story] in DataCon (clarifies existing
stuff)

The most painful bit was that to generate Typeable instances (ie
TyConRepName bindings) for every TyCon is tricky for types in ghc-prim
etc:

 * We need to have enough data types around to *define* a TyCon
 * Many of these types are wired-in

Also, to minimise the code generated for each data type, I wanted to
generate pure data, not CAFs with unpackCString# stuff floating about.

Performance
~~~~~~~~~~~
Three perf/compiler tests start to allocate quite a bit more. This isn't
surprising, because they all allocate zillions of data types, with
practically no other code, esp. T1969

 * T1969:    GHC allocates 19% more
 * T4801:    GHC allocates 13% more
 * T5321FD:  GHC allocates 13% more
 * T9675:    GHC allocates 11% more
 * T783:     GHC allocates 11% more
 * T5642:    GHC allocates 10% more

I'm treating this as acceptable. The payoff comes in Typeable-heavy
code.

Remaining to do
~~~~~~~~~~~~~~~

 * I think that "TyCon" and "Module" are over-generic names to use for
   the runtime type representations used in GHC.Typeable. Better might
be
   "TrTyCon" and "TrModule". But I have not yet done this

 * Add more info the the "TyCon" e.g. source location where it was
   defined

 * Use the new "Module" type to help with Trac Trac #10068

 * It would be possible to generate TyConRepName (ie Typeable
   instances) selectively rather than all the time. We'd need to persist
   the information in interface files. Lacking a motivating reason I
have
   not done this, but it would not be difficult.

Refactoring
~~~~~~~~~~~
As is so often the case, I ended up refactoring more than I intended.
In particular

 * In TyCon, a type *family* (whether type or data) is repesented by a
   FamilyTyCon
     * a algebraic data type (including data/newtype instances) is
       represented by AlgTyCon This wasn't true before; a data family
       was represented as an AlgTyCon. There are some corresponding
       changes in IfaceSyn.

     * Also get rid of the (unhelpfully named) tyConParent.

 * In TyCon define 'Promoted', isomorphic to Maybe, used when things are
   optionally promoted; and use it elsewhere in GHC.

 * Cleanup handling of knownKeyNames

 * Each TyCon, including promoted TyCons, contains its TyConRepName, if
   it has one. This is, in effect, the name of its Typeable instance.

Updates haddock submodule

Test Plan: Let Harbormaster validate

Reviewers: austin, hvr, goldfire

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D1404

GHC Trac Issues: #9858
parent 59e728bc
......@@ -32,7 +32,7 @@ import Unique
import Util
import Name
import BasicTypes
import {-# SOURCE #-} TypeRep (Type, ThetaType)
import TypeRep (Type, ThetaType)
import Var
import Type (mkTyConApp)
......
This diff is collapsed.
......@@ -72,6 +72,7 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
......@@ -586,7 +587,8 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -609,11 +611,24 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
-- used in derived instances
-- Used in derived instances
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
-- incluing the wrinkle about mkSpecialTyConRepName
mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
where
prefix | isDataOcc occ = "$tc'"
| otherwise = "$tc"
mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
where
-- *User-writable* prefix, for types in gHC_TYPES
prefix | isDataOcc occ = "tc'"
| otherwise = "tc"
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
......
......@@ -48,10 +48,13 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
tyConRepNameUnique,
dataConWorkerUnique, dataConRepNameUnique,
mkBuiltinUnique,
mkPseudoUniqueD,
mkPseudoUniqueE,
......@@ -99,9 +102,10 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Int -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
......@@ -109,9 +113,11 @@ mkUniqueGrimily = MkUnique
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
stepUnique (MkUnique i) n = MkUnique (i + n)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
-- SPJ says: this looks terribly smelly to me!
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
......@@ -305,14 +311,19 @@ mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -320,10 +331,22 @@ mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- used for the worker function (the function that builds the constructor
-- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConRepNameUnique u = stepUnique u 2
--------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
......@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-- Respects the let/app invariant by building a case expression where necessary
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp fun (Type ty) = App fun (Type ty)
mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mkCoreApp _ fun (Type ty) = App fun (Type ty)
mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
mk_val_app fun arg arg_ty res_ty
where
fun_ty = exprType fun
......
This diff is collapsed.
......@@ -217,8 +217,8 @@ dsExpr (HsLamCase arg matches)
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
dsExpr e@(HsApp fun arg)
= mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
{-
......@@ -260,15 +260,15 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}
dsExpr (OpApp e1 op _ e2)
dsExpr e@(OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
= mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
= mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr) = do
dsExpr e@(SectionR op expr) = do
core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
......@@ -277,7 +277,7 @@ dsExpr (SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
......
......@@ -241,7 +241,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
......@@ -343,7 +343,7 @@ mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
alt_bndrs = bndrs,
......@@ -536,8 +536,8 @@ into
which stupidly tries to bind the datacon 'True'.
-}
mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
| f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
= Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
where
......@@ -545,10 +545,10 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
_ -> mkWildValBinder ty1
mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific verison of CoreUtils.mkCast,
......
......@@ -414,6 +414,7 @@ Library
TcErrors
TcTyClsDecls
TcTyDecls
TcTypeable
TcType
TcEvidence
TcUnify
......
......@@ -41,7 +41,7 @@ module HsUtils(
mkPatSynBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
......@@ -319,6 +319,10 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString s (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
= HsStringPrim (unpackFS fs) (fastStringToByteString fs)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
......
......@@ -14,7 +14,7 @@ module BuildTyCl (
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
newImplicitBinder
newImplicitBinder, newTyConRepName
) where
#include "HsVersions.h"
......@@ -22,6 +22,7 @@ module BuildTyCl (
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import TysWiredIn( isCTupleTyConName )
import PrelNames( tyConRepModOcc )
import DataCon
import PatSyn
import Var
......@@ -36,6 +37,7 @@ import Id
import Coercion
import TcType
import SrcLoc( noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
......@@ -49,7 +51,8 @@ buildSynonymTyCon :: Name -> [TyVar] -> [Role]
-> TyCon
buildSynonymTyCon tc_name tvs roles rhs rhs_kind
= mkSynonymTyCon tc_name kind tvs roles rhs
where kind = mkPiKinds tvs rhs_kind
where
kind = mkPiKinds tvs rhs_kind
buildFamilyTyCon :: Name -- ^ Type family name
......@@ -57,7 +60,7 @@ buildFamilyTyCon :: Name -- ^ Type family name
-> Maybe Name -- ^ Result variable name
-> FamTyConFlav -- ^ Open, closed or in a boot file?
-> Kind -- ^ Kind of the RHS
-> TyConParent -- ^ Parent, if exists
-> Maybe Class -- ^ Parent, if exists
-> Injectivity -- ^ Injectivity annotation
-- See [Injectivity annotation] in HsDecls
-> TyCon
......@@ -132,7 +135,9 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> Name
-> Bool -- Declared infix
-> Promoted TyConRepName -- Promotable
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
......@@ -148,7 +153,7 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
......@@ -156,11 +161,12 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
......@@ -169,6 +175,7 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
......@@ -227,7 +234,8 @@ type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -240,10 +248,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-- The class name is the 'parent' for this datacon, not its tycon,
-- because one should import the class to get the binding for
-- the datacon
; tc_rep_name <- newTyConRepName tycon_name
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
......@@ -282,6 +287,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
NotPromoted -- Class tycons are not promoted
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
......@@ -300,9 +306,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
else return (mkDataTyConRhs [dict_con])
; let { clas_kind = mkPiKinds tvs constraintKind
; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec
; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec 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 }
......@@ -366,3 +371,12 @@ newImplicitBinder base_name mk_sys_occ
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
| Just mod <- nameModule_maybe tc_name
, (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
= newGlobalBinder mod occ noSrcSpan
| otherwise
= newImplicitBinder tc_name mkTyConRepUserOcc
......@@ -165,7 +165,8 @@ data IfaceTyConParent
IfaceTcArgs
data IfaceFamTyConFlav
= IfaceOpenSynFamilyTyCon
= IfaceDataFamilyTyCon -- Data family
| IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
-- ^ Name of associated axiom and branches for pretty printing purposes,
-- or 'Nothing' for an empty closed family without an axiom
......@@ -192,7 +193,6 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
| IfDataFamTyCon -- Data family
| IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
| IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls
......@@ -343,14 +343,12 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls IfDataFamTyCon = []
visibleIfConDecls (IfDataTyCon cs _ _) = cs
visibleIfConDecls (IfNewTyCon c _ _) = [c]
ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
ifaceConDeclFields x = case x of
IfAbstractTyCon {} -> []
IfDataFamTyCon {} -> []
IfDataTyCon cons is_over labels -> map (help cons is_over) labels
IfNewTyCon con is_over labels -> map (help [con] is_over) labels
where
......@@ -368,35 +366,15 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
= -- implicit newtype coercion
(mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
-- data constructor and worker (newtypes don't have a wrapper)
[con_occ, mkDataConWorkerOcc con_occ]
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
ifCons = IfDataTyCon cons _ _ })
= -- for each data constructor in order,
-- data constructor, worker, and (possibly) wrapper
concatMap dc_occs cons
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
| otherwise = [con_occ, work_occ]
where
con_occ = ifConOcc con_decl -- DataCon namespace
wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
work_occ = mkDataConWorkerOcc con_occ -- Id namespace
has_wrapper = ifConWrapper con_decl -- This is the reason for
-- having the ifConWrapper field!
ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifSigs = sigs, ifATs = ats })
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons })
= case cons of
IfAbstractTyCon {} -> []
IfNewTyCon cd _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
, ifSigs = sigs, ifATs = ats })
= -- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
......@@ -420,6 +398,14 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifaceDeclImplicitBndrs _ = []
ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ })
= [con_occ, work_occ] ++ wrap_occs
where
work_occ = mkDataConWorkerOcc con_occ -- Id namespace
wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace
| otherwise = []
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl
......@@ -685,7 +671,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_nd = case condecls of
IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
IfDataFamTyCon -> ptext (sLit "data family")
IfDataTyCon{} -> ptext (sLit "data")
IfNewTyCon{} -> ptext (sLit "newtype")
......@@ -694,6 +679,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_prom | is_prom = ptext (sLit "Promotable")
| otherwise = Outputable.empty
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
......@@ -738,7 +724,12 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind
, ifResVar = res_var, ifFamInj = inj })
= vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars)
| IfaceDataFamilyTyCon <- rhs
= ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars
| otherwise
= vcat [ hang (ptext (sLit "type family")
<+> pprIfaceDeclHead [] ss tycon tyvars)
2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
, ppShowRhs ss (nest 2 (pp_branches rhs)) ]
where
......@@ -752,11 +743,13 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
[] -> empty
tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (ptext (sLit "data"))
pp_rhs IfaceOpenSynFamilyTyCon
= ppShowIface ss (ptext (sLit "open"))
pp_rhs IfaceAbstractClosedSynFamilyTyCon
= ppShowIface ss (ptext (sLit "closed, abstract"))
pp_rhs (IfaceClosedSynFamilyTyCon _)
pp_rhs (IfaceClosedSynFamilyTyCon {})
= ptext (sLit "where")
pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (ptext (sLit "built-in"))
......@@ -1170,12 +1163,13 @@ freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......@@ -1526,18 +1520,22 @@ instance Binary IfaceDecl where
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
instance Binary IfaceFamTyConFlav where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ bh IfaceDataFamilyTyCon = putByte bh 0
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
get bh = do { h <- getByte bh
; case h of
0 -> return IfaceOpenSynFamilyTyCon
1 -> do { mb <- get bh
0 -> return IfaceDataFamilyTyCon
1 -> return IfaceOpenSynFamilyTyCon
2 -> do { mb <- get bh
; return (IfaceClosedSynFamilyTyCon mb) }
_ -> return IfaceAbstractClosedSynFamilyTyCon }
3 -> return IfaceAbstractClosedSynFamilyTyCon
_ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
(ppr (fromIntegral h :: Int)) }
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
......@@ -1576,17 +1574,16 @@ instance Binary IfaceAxBranch where
return (IfaceAxBranch a1 a2 a3 a4 a5)
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh IfDataFamTyCon = putByte bh 1
put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
get bh = do
h <- getByte bh
case h of
0 -> liftM IfAbstractTyCon $ get bh
1 -> return IfDataFamTyCon
2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
_ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
_ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
......
......@@ -1611,7 +1611,7 @@ tyConToIfaceDecl env tycon
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
ifPromotable = isPromotableTyCon tycon,
ifParent = parent })
| otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
......@@ -1649,16 +1649,14 @@ tyConToIfaceDecl env tycon
axn = coAxiomName ax
to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
= IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav AbstractClosedSynFamilyTyCon
= IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
to_if_fam_flav (BuiltInSynFamTyCon {})
= IfaceBuiltInSynFamTyCon
ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon
ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False []
ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
-- The AbstractTyCon case happens when a TyCon has been trimmed
......
......@@ -297,13 +297,13 @@ What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.
-}
tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing