summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/OccName.hs13
-rw-r--r--compiler/basicTypes/Unique.hs16
-rw-r--r--compiler/iface/BuildTyCl.hs4
-rw-r--r--compiler/prelude/PrelNames.hs40
-rw-r--r--compiler/prelude/TysPrim.hs4
-rw-r--r--compiler/prelude/TysWiredIn.hs113
-rw-r--r--compiler/typecheck/TcRnDriver.hs5
-rw-r--r--compiler/typecheck/TcTypeable.hs155
-rw-r--r--compiler/types/TyCon.hs31
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs2
10 files changed, 223 insertions, 160 deletions
diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index f7020a95f4..28256fb67b 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -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
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index c9c2240490..e330aedb28 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -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
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 75e8875d59..699fd5d366 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -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
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index bc7951a5ec..609ac03ad1 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -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,
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 14505850fd..d1e42d5a10 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -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
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 3b2213d359..cb9438a1ad 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 90d07a33da..efb703c953 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -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 ;
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index b750340720..0be765c949 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -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)
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 0f64cf91cb..676d2f9a52 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -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
+ 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 = (rep_module, mkTyConRepOcc tc_occ)
+ where
+ rep_module
+ | tc_module == gHC_PRIM = gHC_TYPES
+ | otherwise = tc_module
+
{- *********************************************************************
* *
@@ -1196,7 +1225,7 @@ mkTcTyCon name kind
-- | Create an unlifted primitive 'TyCon', such as @Int#@
mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
mkPrimTyCon name kind roles rep
- = mkPrimTyCon' name kind roles rep True Nothing
+ = mkPrimTyCon' name kind roles rep True (Just $ mkPrelTyConRepName name)
-- | Kind constructors
mkKindTyCon :: Name -> Kind -> [Role] -> Name -> TyCon
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 859df3749b..03e7d27d0e 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -100,7 +100,7 @@ vectTyConDecl tycon name'
gadt_flag = isGadtSyntaxTyCon tycon
-- build the vectorised type constructor
- ; tc_rep_name <- mkDerivedName mkTyConRepUserOcc name'
+ ; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
; return $ mkAlgTyCon
name' -- new name
(tyConKind tycon) -- keep original kind
View Lorry Controller Status