Commit 84b0ebed authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Rework derivation of type representations for wired-in things

Previously types defined by `GHC.Types` and `GHC.Prim` had their
`Typeable` representations manually defined in `GHC.Typeable.Internals`.
This was terrible, resulting in a great deal of boilerplate and a number
of bugs due to missing or inconsistent representations (see #11120).

Here we take a different tack, initially proposed by Richard Eisenberg:
We wire-in the `Module`, `TrName`, and `TyCon` types, allowing them to
be used in `GHC.Types`. We then allow the usual type representation
generation logic to handle this module.

`GHC.Prim`, on the other hand, is a bit tricky as it has no object code
of its own.  To handle this we instead place the type representations
for the types defined here in `GHC.Types`.

On the whole this eliminates several special-cases as well as a fair
amount of boilerplate from hand-written representations. Moreover, we
get full coverage of primitive types for free.

Test Plan: Validate

Reviewers: goldfire, simonpj, austin, hvr

Subscribers: goldfire, simonpj, thomie

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

GHC Trac Issues: #11120
parent 5cce0954
......@@ -71,7 +71,7 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc,
mkTyConRepOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
......@@ -591,7 +591,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc
mkTyConRepOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -617,18 +617,11 @@ 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
mkTyConRepOcc 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
......
......@@ -317,15 +317,13 @@ mkCoVarUnique i = mkUnique 'g' i
mkPreludeClassUnique i = mkUnique '2' i
--------------------------------------------------
-- 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)
-- Wired-in type constructor keys occupy *two* slots:
-- * u: the TyCon itself
-- * u+1: the TyConRepName of the TyCon
mkPreludeTyConUnique i = mkUnique '3' (2*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (2*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a)
mkCTupleTyConUnique a = mkUnique 'k' (2*a)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
......
......@@ -18,7 +18,7 @@ module BuildTyCl (
import IfaceEnv
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import TysWiredIn( isCTupleTyConName, tyConRepModOcc )
import TysWiredIn( isCTupleTyConName )
import DataCon
import PatSyn
import Var
......@@ -357,4 +357,4 @@ newTyConRepName tc_name
, (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
= newGlobalBinder mod occ noSrcSpan
| otherwise
= newImplicitBinder tc_name mkTyConRepUserOcc
= newImplicitBinder tc_name mkTyConRepOcc
......@@ -208,13 +208,11 @@ basicKnownKeyNames
-- Typeable
typeableClassName,
typeRepTyConName,
trTyConDataConName,
trModuleDataConName,
trNameSDataConName,
typeRepIdName,
mkPolyTyConAppName,
mkAppTyName,
typeSymbolTypeRepName, typeNatTypeRepName,
trGhcPrimModuleName,
-- Dynamic
toDynName,
......@@ -818,16 +816,6 @@ and it's convenient to write them all down in one place.
-- guys as well (perhaps) e.g. see trueDataConName below
-}
-- | Build a 'Name' for the 'Typeable' representation of the given special 'TyCon'.
-- Special 'TyCon's include @(->)@, @BOX@, @Constraint@, etc. See 'TysPrim'.
mkSpecialTyConRepName :: FastString -> Name -> Name
-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
mkSpecialTyConRepName fs tc_name
= mkExternalName (tyConRepNameUnique (nameUnique tc_name))
tYPEABLE_INTERNAL
(mkVarOccFS fs)
wiredInSrcSpan
wildCardName :: Name
wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
......@@ -1145,25 +1133,23 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
-- Class Typeable, and functions for constructing `Typeable` dictionaries
typeableClassName
, typeRepTyConName
, trTyConDataConName
, trModuleDataConName
, trNameSDataConName
, mkPolyTyConAppName
, mkAppTyName
, typeRepIdName
, typeNatTypeRepName
, typeSymbolTypeRepName
, trGhcPrimModuleName
:: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey
trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey
trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey
trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey
typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey
mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey
typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey
-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)
-- See Note [Grand plan for Typeable] in TcTypeable.
trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey
-- Custom type errors
errorMessageTypeErrorFamName
......@@ -1805,10 +1791,18 @@ liftedDataConKey, unliftedDataConKey :: Unique
liftedDataConKey = mkPreludeDataConUnique 39
unliftedDataConKey = mkPreludeDataConUnique 40
trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique
trTyConDataConKey = mkPreludeDataConUnique 41
trModuleDataConKey = mkPreludeDataConUnique 42
trNameSDataConKey = mkPreludeDataConUnique 43
trTyConTyConKey, trTyConDataConKey,
trModuleTyConKey, trModuleDataConKey,
trNameTyConKey, trNameSDataConKey, trNameDDataConKey,
trGhcPrimModuleKey :: Unique
trTyConTyConKey = mkPreludeDataConUnique 41
trTyConDataConKey = mkPreludeDataConUnique 42
trModuleTyConKey = mkPreludeDataConUnique 43
trModuleDataConKey = mkPreludeDataConUnique 44
trNameTyConKey = mkPreludeDataConUnique 45
trNameSDataConKey = mkPreludeDataConUnique 46
trNameDDataConKey = mkPreludeDataConUnique 47
trGhcPrimModuleKey = mkPreludeDataConUnique 48
typeErrorTextDataConKey,
typeErrorAppendDataConKey,
......
......@@ -272,7 +272,7 @@ funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
-- because they are never in scope in the source
tc_rep_nm = mkSpecialTyConRepName (fsLit "tcFun") funTyConName
tc_rep_nm = mkPrelTyConRepName funTyConName
-- One step to remove subkinding.
-- (->) :: * -> * -> *
......@@ -329,7 +329,7 @@ tYPETyConName, unliftedTypeKindTyConName :: Name
tYPETyCon = mkKindTyCon tYPETyConName
(ForAllTy (Anon levityTy) liftedTypeKind)
[Nominal]
(mkSpecialTyConRepName (fsLit "tcTYPE") tYPETyConName)
(mkPrelTyConRepName tYPETyConName)
-- See Note [TYPE]
-- NB: unlifted is wired in because there is no way to parse it in
......
......@@ -88,17 +88,20 @@ module TysWiredIn (
mkWiredInIdName, -- used in MkId
-- * Type representations
trModuleTyCon, trModuleDataCon,
trNameTyCon, trNameSDataCon, trNameDDataCon,
trTyConTyCon, trTyConDataCon,
-- * Levity
levityTy, levityTyCon, liftedDataCon, unliftedDataCon,
liftedPromDataCon, unliftedPromDataCon,
liftedDataConTy, unliftedDataConTy,
liftedDataConName, unliftedDataConName,
-- * Helpers for building type representations
tyConRepModOcc
) where
#include "HsVersions.h"
#include "MachDeps.h"
import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )
......@@ -120,7 +123,7 @@ import RdrName
import Name
import NameSet ( NameSet, mkNameSet, elemNameSet )
import BasicTypes ( Arity, RecFlag(..), Boxity(..),
TupleSort(..) )
TupleSort(..) )
import ForeignCall
import SrcLoc ( noSrcSpan )
import Unique
......@@ -136,48 +139,6 @@ alpha_tyvar = [alphaTyVar]
alpha_ty :: [Type]
alpha_ty = [alphaTy]
-- * Some helpers for generating type representations
-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type
mkPrelTyConRepName :: Name -> Name
-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
-- This doesn't really belong here but a refactoring of this code eliminating
-- these manually-defined representations is imminent
mkPrelTyConRepName tc_name -- Prelude tc_name is always External,
-- so nameModule will work
= mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)
where
name_occ = nameOccName tc_name
name_mod = nameModule tc_name
name_uniq = nameUnique tc_name
rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq
| otherwise = dataConRepNameUnique name_uniq
(rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ
-- | The name (and defining module) for the Typeable representation (TyCon) of a
-- type constructor.
--
-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
tyConRepModOcc :: Module -> OccName -> (Module, OccName)
tyConRepModOcc tc_module tc_occ
-- The list type is defined in GHC.Types and therefore must have its
-- representations defined manually in Data.Typeable.Internal.
-- However, $tc': isn't a valid Haskell identifier, so we override the derived
-- name here.
| is_wired_in promotedConsDataCon
= (tYPEABLE_INTERNAL, mkOccName varName "tc'Cons")
| is_wired_in promotedNilDataCon
= (tYPEABLE_INTERNAL, mkOccName varName "tc'Nil")
| tc_module == gHC_TYPES
= (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ)
| otherwise
= (tc_module, mkTyConRepSysOcc tc_occ)
where
is_wired_in :: TyCon -> Bool
is_wired_in tc =
tc_module == gHC_TYPES && tc_occ == nameOccName (tyConName tc)
{-
************************************************************************
* *
......@@ -227,6 +188,9 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, liftedTypeKindTyCon
, starKindTyCon
, unicodeStarKindTyCon
, trModuleTyCon
, trTyConTyCon
, trNameTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
......@@ -661,7 +625,7 @@ heqSCSelId, coercibleSCSelId :: Id
where
tycon = mkClassTyCon heqTyConName kind tvs roles
rhs klass NonRecursive
(mkSpecialTyConRepName (fsLit "tcHEq") heqTyConName)
(mkPrelTyConRepName heqTyConName)
klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon
datacon = pcDataCon heqDataConName tvs [sc_pred] tycon
......@@ -912,7 +876,7 @@ listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
Nothing []
(DataTyCon [nilDataCon, consDataCon] False )
Recursive False
(VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcList") listTyConName))
(VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
......@@ -1099,3 +1063,56 @@ promotedGTDataCon = promoteDataCon gtDataCon
promotedConsDataCon, promotedNilDataCon :: TyCon
promotedConsDataCon = promoteDataCon consDataCon
promotedNilDataCon = promoteDataCon nilDataCon
-- * Type representation types
-- See Note [Grand plan for Typable] in TcTypeable.
trModuleTyConName, trNameTyConName, trTyConTyConName :: Name
trModuleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Module")
trModuleTyConKey trModuleTyCon
trNameTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "TrName")
trNameTyConKey trNameTyCon
trTyConTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "TyCon")
trTyConTyConKey trTyConTyCon
trModuleDataConName, trTyConDataConName,
trNameSDataConName, trNameDDataConName :: Name
trModuleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Module")
trModuleDataConKey trModuleDataCon
trTyConDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TyCon")
trTyConDataConKey trTyConDataCon
trNameSDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TrNameS")
trNameSDataConKey trNameSDataCon
trNameDDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TrNameD")
trNameDDataConKey trNameDDataCon
trModuleTyCon :: TyCon
trModuleTyCon = pcNonRecDataTyCon trModuleTyConName Nothing [] [trModuleDataCon]
trModuleDataCon :: DataCon
trModuleDataCon = pcDataCon trModuleDataConName [] [trNameTy, trNameTy] trModuleTyCon
trModuleTy :: Type
trModuleTy = mkTyConTy trModuleTyCon
trNameTyCon :: TyCon
trNameTyCon = pcNonRecDataTyCon trNameTyConName Nothing [] [trNameSDataCon, trNameDDataCon]
trNameSDataCon, trNameDDataCon :: DataCon
trNameSDataCon = pcDataCon trNameSDataConName [] [addrPrimTy] trNameTyCon
trNameDDataCon = pcDataCon trNameDDataConName [] [stringTy] trNameTyCon
trNameTy :: Type
trNameTy = mkTyConTy trNameTyCon
trTyConTyCon :: TyCon
trTyConTyCon = pcNonRecDataTyCon trTyConTyConName Nothing [] [trTyConDataCon]
trTyConDataCon :: DataCon
trTyConDataCon = pcDataCon trTyConDataConName [] [fprint, fprint, trModuleTy, trNameTy] trTyConTyCon
where
-- TODO: This should be for the target, no?
#if WORD_SIZE_IN_BITS < 64
fprint = word64PrimTy
#else
fprint = wordPrimTy
#endif
......@@ -71,7 +71,7 @@ import TcType
import MkIface
import TcSimplify
import TcTyClsDecls
import TcTypeable( mkModIdBindings )
import TcTypeable( mkModIdBindings, mkPrimTypeableBinds )
import LoadIface
import TidyPgm ( mkBootModDetailsTc )
import RnNames
......@@ -475,8 +475,9 @@ tcRnSrcDecls explicit_mod_hdr decls
-- Do this before processing any data type declarations,
-- which need tcg_tr_module to be initialised
; tcg_env <- mkModIdBindings
; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
-- Do all the declarations
-- Do all the declarations
; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env $
captureConstraints $
do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
......
......@@ -4,7 +4,7 @@
-}
module TcTypeable(
mkTypeableBinds, mkModIdBindings
mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings
) where
......@@ -12,7 +12,10 @@ import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TcEnv
import TcRnMonad
import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
import PrelNames
import TysPrim ( primTyCons )
import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon
, trTyConDataCon, trNameSDataCon )
import Id
import Type
import TyCon
......@@ -55,45 +58,32 @@ The overall plan is this:
3. Record the TyConRepName in T's TyCon, including for promoted
data and type constructors, and kinds like * and #.
The TyConRepNaem is not an "implicit Id". It's more like a record
The TyConRepName is not an "implicit Id". It's more like a record
selector: the TyCon knows its name but you have to go to the
interface file to find its type, value, etc
4. Solve Typeable costraints. This is done by a custom Typeable solver,
4. Solve Typeable constraints. This is done by a custom Typeable solver,
currently in TcInteract, that use M.$tcT so solve (Typeable T).
There are many wrinkles:
* Since we generate $tcT for every data type T, the types TyCon and
Module must be available right from the start; so they are defined
in ghc-prim:GHC.Types
Module must be available right from the start; so they are wired in (and
defined in ghc-prim:GHC.Types).
* GHC.Prim doesn't have any associated object code, so we need to put the
representations for types defined in this module elsewhere. We put these
in GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for injecting
the bindings for the GHC.Prim representions when compiling GHC.Types.
* TyCon.tyConRepModOcc is responsible for determining where to find
the representation binding for a given type. This is where we handle
the special case for GHC.Prim.
* To save space and reduce dependencies, we need use quite low-level
representations for TyCon and Module. See GHC.Types
Note [Runtime representation of modules and tycons]
* It's hard to generate the TyCon/Module bindings when the types TyCon
and Module aren't yet available; i.e. when compiling GHC.Types
itself. So we *don't* generate them for types in GHC.Types. Instead
we write them by hand in base:GHC.Typeable.Internal.
* To be able to define them by hand, they need to have user-writable
names, thus
tcBool not $tcBool for the type-rep TyCon for Bool
Hence PrelNames.tyConRepModOcc
* Moreover for type constructors with special syntax, they need to have
completely hand-crafted names
lists tcList not $tc[] for the type-rep TyCon for []
kinds tcLiftedKind not $tc* for the type-rep TyCon for *
Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
to use for the TyConRepName
* Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
be wired in as well. For these wired-in TyCons we generate the
TyConRepName's unique from that of the TyCon; see
Unique.tyConRepNameUnique, dataConRepNameUnique.
-}
{- *********************************************************************
......@@ -105,24 +95,21 @@ There are many wrinkles:
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; if mod == gHC_TYPES
then getGblEnv -- Do not generate bindings for modules in GHC.Types
else
do { loc <- getSrcSpanM
; tr_mod_dc <- tcLookupDataCon trModuleDataConName
; tr_name_dc <- tcLookupDataCon trNameSDataConName
; loc <- getSrcSpanM
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; let mod_ty = mkTyConApp (dataConTyCon tr_mod_dc) []
mod_id = mkExportedVanillaId mod_nm mod_ty
mod_bind = mkVarBind mod_id mod_rhs
mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
[ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
, trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
; let mod_id = mkExportedVanillaId mod_nm
(mkTyConApp trModuleTyCon [])
mod_bind = mkVarBind mod_id (mkModIdRHS mod)
; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
; return (tcg_env { tcg_tr_module = Just mod_id }
`addTypecheckedBinds` [unitBag mod_bind]) } }
`addTypecheckedBinds` [unitBag mod_bind]) }
mkModIdRHS :: Module -> LHsExpr Id
mkModIdRHS mod
= nlHsApps (dataConWrapId trModuleDataCon)
[ trNameLit (unitIdFS (moduleUnitId mod))
, trNameLit (moduleNameFS (moduleName mod)) ]
{- *********************************************************************
* *
......@@ -132,40 +119,79 @@ mkModIdBindings
mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
mkTypeableBinds tycons
= do { dflags <- getDynFlags
= do { dflags <- getDynFlags
; gbl_env <- getGblEnv
; mod <- getModule
; if mod == gHC_TYPES
then return gbl_env -- Do not generate bindings for modules in GHC.Types
else
do { tr_datacon <- tcLookupDataCon trTyConDataConName
; trn_datacon <- tcLookupDataCon trNameSDataConName
; let pkg_str = unitIdString (moduleUnitId mod)
mod_str = moduleNameString (moduleName mod)
mod_expr = case tcg_tr_module gbl_env of -- Should be set by now
Just mod_id -> nlHsVar mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
stuff = (dflags, mod_expr, pkg_str, mod_str)
all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
-- We need type representations for any associated types
tc_binds = map (mk_typeable_binds stuff) all_tycons
tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv
; return (gbl_env `addTypecheckedBinds` tc_binds) } }
; return (gbl_env `addTypecheckedBinds` tc_binds) }
-- | Generate bindings for the type representation of a wired-in TyCon defined
-- by the virtual "GHC.Prim" module. This is where we inject the representation
-- bindings for primitive types into "GHC.Types"
--
-- See Note [Grand plan for Typeable] in this module.
mkPrimTypeableBinds :: TcM TcGblEnv
mkPrimTypeableBinds
= do { dflags <- getDynFlags
; mod <- getModule
; let prim_binds :: LHsBinds Id
prim_binds
| mod == gHC_TYPES = ghcPrimTypeableBinds dflags
| otherwise = emptyBag
prim_rep_ids = collectHsBindsBinders prim_binds
; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
; return (gbl_env `addTypecheckedBinds` [prim_binds]) }
-- | Generate bindings for the type representation of the wired-in TyCons defined
-- by the virtual "GHC.Prim" module. This differs from the usual
-- @mkTypeableBinds@ path in that here we need to lie to 'mk_typeable_binds'
-- about the module we are compiling (since we are currently compiling
-- "GHC.Types" yet are producing representations for types in "GHC.Prim").
--
-- See Note [Grand plan for Typeable] in this module.
ghcPrimTypeableBinds :: DynFlags -> LHsBinds Id
ghcPrimTypeableBinds dflags
= ghc_prim_module_bind `unionBags` unionManyBags (map mkBind all_prim_tys)
where
all_prim_tys :: [TyCon]
all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
, tc' <- tc : tyConATs tc ]
ghc_prim_module_id =
mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon)
ghc_prim_module_bind =
unitBag $ mkVarBind ghc_prim_module_id (mkModIdRHS gHC_PRIM)
stuff :: TypeableStuff
stuff = (dflags, nlHsVar ghc_prim_module_id, "ghc-prim", "GHC.Prim")
trNameLit :: DataCon -> FastString -> LHsExpr Id
trNameLit tr_name_dc fs
= nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
mkBind :: TyCon -> LHsBinds Id
mkBind = mk_typeable_binds stuff
trNameLit :: FastString -> LHsExpr Id
trNameLit fs
= nlHsApps (dataConWrapId trNameSDataCon) [nlHsLit (mkHsStringPrimLit fs)]
type TypeableStuff
= ( DynFlags
, LHsExpr Id -- Of type GHC.Types.Module
, String -- Package name
, String -- Module name
, DataCon -- Data constructor GHC.Types.TyCon
, DataCon ) -- Data constructor GHC.Types.TrNameS
)
-- | Make bindings for the type representations of a 'TyCon' and its
-- promoted constructors.
mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
mk_typeable_binds stuff tycon
= mkTyConRepBinds stuff tycon
......@@ -173,18 +199,26 @@ mk_typeable_binds stuff tycon
unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
mkTyConRepBinds stuff tycon
= case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where
rep_id = mkExportedVanillaId rep_name (mkTyConApp tr_tycon [])
rep_id = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon [])
rep_rhs = mkTyConRepRHS stuff tycon
_ -> emptyBag
-- | Produce typeable binds for the promoted 'TyCon' of a data constructor
mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
mkTypeableDataConBinds stuff dc
= mkTyConRepBinds stuff (promoteDataCon dc)
mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
where
tr_tycon = dataConTyCon tr_datacon
rep_rhs = nlHsApps (dataConWrapId tr_datacon)
rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
[ nlHsLit (word64 high), nlHsLit (word64 low)
, mod_expr
, trNameLit trn_datacon (mkFastString tycon_str) ]
, trNameLit (mkFastString tycon_str) ]
tycon_str = add_tick (occNameString (getOccName tycon))
add_tick s | isPromotedDataCon tycon = '\'' : s
......@@ -199,6 +233,3 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty
word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
| otherwise = \n -> HsWordPrim (show n) (toInteger n)
mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
mkTypeableDataConBinds stuff dc
= mkTyConRepBinds stuff (promoteDataCon dc)
......@@ -91,6 +91,8 @@ module TyCon(
-- * Runtime type representation
TyConRepName, tyConRepName_maybe,
mkPrelTyConRepName,
tyConRepModOcc,
-- * Primitive representations of Types
PrimRep(..), PrimElemRep(..),
......@@ -124,6 +126,8 @@ import FastStringEnv
import FieldLabel
import Constants
import Util
import Unique( tyConRepNameUnique, dataConRepNameUnique )
import Module
import qualified Data.Data as Data
import Data.Typeable (Typeable)
......@@ -914,6 +918,31 @@ tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm })
= Just rep_nm
tyConRepName_maybe _ = Nothing
-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type
mkPrelTyConRepName :: Name -> TyConRepName
-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
mkPrelTyConRepName tc_name -- Prelude tc_name is always External,
-- so nameModule will work
= mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)
where
name_occ = nameOccName tc_name