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

3 files changed, 84 insertions, 73 deletions

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