summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <bgamari.foss@gmail.com>2016-02-18 22:05:02 +0100
committerBen Gamari <ben@smart-cactus.org>2016-02-18 22:08:16 +0100
commit206a8bf4665af216784357f6741ccf5e68dd2495 (patch)
treecac5afabf84ac0c01f17a657966a2110e1078330
parenta008eadfaa4816be349b4fefde9b9b9edc1ca359 (diff)
downloadhaskell-206a8bf4665af216784357f6741ccf5e68dd2495.tar.gz
Unwire Typeable representation types
In order to make this work I needed to shuffle around typechecking a bit such that `TyCon` and friends are available during compilation of GHC.Types. I also did a bit of refactoring of `TcTypeable`. Test Plan: Validate Reviewers: simonpj, austin Subscribers: simonpj, thomie Differential Revision: https://phabricator.haskell.org/D1906 GHC Trac Issues: #11120
-rw-r--r--compiler/prelude/PrelNames.hs22
-rw-r--r--compiler/prelude/TysWiredIn.hs62
-rw-r--r--compiler/typecheck/TcRnDriver.hs20
-rw-r--r--compiler/typecheck/TcTyDecls.hs6
-rw-r--r--compiler/typecheck/TcTypeable.hs193
-rw-r--r--libraries/ghc-prim/GHC/Types.hs2
-rw-r--r--testsuite/tests/deSugar/should_compile/T2431.stderr10
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print019.stderr2
-rw-r--r--testsuite/tests/roles/should_compile/Roles13.stderr60
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.stderr104
-rw-r--r--testsuite/tests/simplCore/should_compile/T8274.stdout4
-rw-r--r--testsuite/tests/stranal/should_compile/T10694.stdout4
12 files changed, 249 insertions, 240 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 609ac03ad1..5c2984be2a 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -205,6 +205,11 @@ basicKnownKeyNames
ioTyConName, ioDataConName,
runMainIOName,
+ -- Type representation types
+ trModuleTyConName, trModuleDataConName,
+ trNameTyConName, trNameSDataConName, trNameDDataConName,
+ trTyConTyConName, trTyConDataConName,
+
-- Typeable
typeableClassName,
typeRepTyConName,
@@ -1130,6 +1135,23 @@ rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDo
ixClassName :: Name
ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
+-- Typeable representation types
+trModuleTyConName
+ , trModuleDataConName
+ , trNameTyConName
+ , trNameSDataConName
+ , trNameDDataConName
+ , trTyConTyConName
+ , trTyConDataConName
+ :: Name
+trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey
+trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey
+trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey
+trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey
+trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey
+trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey
+trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey
+
-- Class Typeable, and functions for constructing `Typeable` dictionaries
typeableClassName
, typeRepTyConName
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 6ad786fd0f..b7bd186e86 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -88,11 +88,6 @@ module TysWiredIn (
mkWiredInIdName, -- used in MkId
- -- * Type representations
- trModuleTyCon, trModuleDataCon,
- trNameTyCon, trNameSDataCon, trNameDDataCon,
- trTyConTyCon, trTyConDataCon,
-
-- * Levity
levityTy, levityTyCon, liftedDataCon, unliftedDataCon,
liftedPromDataCon, unliftedPromDataCon,
@@ -188,9 +183,6 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, liftedTypeKindTyCon
, starKindTyCon
, unicodeStarKindTyCon
- , trModuleTyCon
- , trTyConTyCon
- , trNameTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -615,6 +607,7 @@ unboxedUnitDataCon = tupleDataCon Unboxed 0
********************************************************************* -}
-- See Note [The equality types story] in TysPrim
+-- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
heqTyCon, coercibleTyCon :: TyCon
heqClass, coercibleClass :: Class
heqDataCon, coercibleDataCon :: DataCon
@@ -1063,56 +1056,3 @@ 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 b483b84b33..fdc6e5e638 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, mkPrimTypeableBinds )
+import TcTypeable ( mkTypeableBinds )
import LoadIface
import TidyPgm ( mkBootModDetailsTc )
import RnNames
@@ -471,21 +471,19 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls explicit_mod_hdr decls
- = do { -- Create a binding for $trModule
- -- 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
- ; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env $
- captureConstraints $
+ = do { -- Do all the declarations
+ ; ((tcg_env, tcl_env), lie) <- captureConstraints $
do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
; return (tcg_env, tcl_env) }
; setEnvs (tcg_env, tcl_env) $ do {
+ -- Emit Typeable bindings
+ ; tcg_env <- setGblEnv tcg_env mkTypeableBinds
+
+ ; setGblEnv tcg_env $ do {
+
#ifdef GHCI
; finishTH
#endif /* GHCI */
@@ -544,7 +542,7 @@ tcRnSrcDecls explicit_mod_hdr decls
; setGlobalTypeEnv tcg_env' final_type_env
- } }
+ } } }
tc_rn_src_decls :: [LHsDecl RdrName]
-> TcM (TcGblEnv, TcLclEnv)
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 314e20c7ae..dce33d3989 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -30,7 +30,6 @@ module TcTyDecls(
import TcRnMonad
import TcEnv
-import TcTypeable( mkTypeableBinds )
import TcBinds( tcRecSelBinds )
import TyCoRep( Type(..), TyBinder(..), delBinderVar )
import TcType
@@ -863,10 +862,7 @@ tcAddImplicits tycons
do { traceTc "tcAddImplicits" $ vcat
[ text "tycons" <+> ppr tycons
, text "implicits" <+> ppr implicit_things ]
- ; gbl_env <- mkTypeableBinds tycons
- ; gbl_env <- setGblEnv gbl_env $
- tcRecSelBinds (mkRecSelBinds tycons)
- ; return gbl_env }
+ ; tcRecSelBinds (mkRecSelBinds tycons) }
where
implicit_things = concatMap implicitTyConThings tycons
def_meth_ids = mkDefaultMethodIds tycons
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index 0be765c949..3b380f76e8 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -3,9 +3,9 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
-}
-module TcTypeable(
- mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings
- ) where
+{-# LANGUAGE RecordWildCards #-}
+
+module TcTypeable(mkTypeableBinds) where
import TcBinds( addTypecheckedBinds )
@@ -14,8 +14,6 @@ import TcEnv
import TcRnMonad
import PrelNames
import TysPrim ( primTyCons )
-import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon
- , trTyConDataCon, trNameSDataCon )
import Id
import Type
import TyCon
@@ -28,9 +26,10 @@ import DynFlags
import Bag
import Fingerprint(Fingerprint(..), fingerprintString)
import Outputable
-import Data.Word( Word64 )
import FastString ( FastString, mkFastString )
+import Data.Word( Word64 )
+
{- Note [Grand plan for Typeable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The overall plan is this:
@@ -67,14 +66,16 @@ The overall plan is this:
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 wired in (and
- defined in ghc-prim:GHC.Types).
+* The timing of when we produce this bindings is rather important: they must be
+ defined after the rest of the module has been typechecked since we need to be
+ able to lookup Module and TyCon in the type environment and we may be
+ currently compiling GHC.Types (where they are defined).
* 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.
+ representations for types defined in this module elsewhere. We chose this
+ place to be 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
@@ -86,6 +87,32 @@ There are many wrinkles:
-}
+-- | Generate the Typeable bindings for a module. This is the only
+-- entry-point of this module and is invoked by the typechecker driver in
+-- 'tcRnSrcDecls'.
+--
+-- See Note [Grand plan for Typeable] in TcTypeable.
+mkTypeableBinds :: TcM TcGblEnv
+mkTypeableBinds
+ = do { -- Create a binding for $trModule.
+ -- Do this before processing any data type declarations,
+ -- which need tcg_tr_module to be initialised
+ ; tcg_env <- mkModIdBindings
+ -- Now we can generate the TyCon representations...
+ -- First we handle the primitive TyCons if we are compiling GHC.Types
+ ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
+ -- Then we produce bindings for the user-defined types in this module.
+ ; setGblEnv tcg_env $
+ let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
+ in mkTypeableTyConBinds tycons
+ }
+ where
+ needs_typeable_binds tc =
+ (not (isFamInstTyCon tc) && isAlgTyCon tc)
+ || isDataFamilyTyCon tc
+ || isClassTyCon tc
+
+
{- *********************************************************************
* *
Building top-level binding for $trModule
@@ -96,20 +123,23 @@ mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; loc <- getSrcSpanM
- ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
- ; let mod_id = mkExportedVanillaId mod_nm
- (mkTyConApp trModuleTyCon [])
- mod_bind = mkVarBind mod_id (mkModIdRHS mod)
+ ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+ ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
+ ; 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]) }
-mkModIdRHS :: Module -> LHsExpr Id
+mkModIdRHS :: Module -> TcM (LHsExpr Id)
mkModIdRHS mod
- = nlHsApps (dataConWrapId trModuleDataCon)
- [ trNameLit (unitIdFS (moduleUnitId mod))
- , trNameLit (moduleNameFS (moduleName mod)) ]
+ = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
+ ; trNameLit <- mkTrNameLit
+ ; return $ nlHsApps (dataConWrapId trModuleDataCon)
+ [ trNameLit (unitIdFS (moduleUnitId mod))
+ , trNameLit (moduleNameFS (moduleName mod)) ]
+ }
{- *********************************************************************
* *
@@ -117,18 +147,16 @@ mkModIdRHS mod
* *
********************************************************************* -}
-mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
-mkTypeableBinds tycons
- = do { dflags <- getDynFlags
- ; gbl_env <- getGblEnv
+-- | Generate TyCon bindings for a set of type constructors
+mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv
+mkTypeableTyConBinds tycons
+ = do { gbl_env <- getGblEnv
; mod <- getModule
- ; 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
+ ; let 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)
- all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
+ ; stuff <- collect_stuff mod mod_expr
+ ; let 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
@@ -143,15 +171,28 @@ mkTypeableBinds tycons
-- 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]) }
+ = do { mod <- getModule
+ ; if mod == gHC_TYPES
+ then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName
+ ; let ghc_prim_module_id =
+ mkExportedVanillaId trGhcPrimModuleName
+ (mkTyConTy trModuleTyCon)
+
+ ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
+ <$> mkModIdRHS gHC_PRIM
+
+ ; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id)
+ ; let prim_binds :: LHsBinds Id
+ prim_binds = unitBag ghc_prim_module_bind
+ `unionBags` ghcPrimTypeableBinds stuff
+
+ prim_rep_ids = collectHsBindsBinders prim_binds
+ ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
+ ; return (gbl_env `addTypecheckedBinds` [prim_binds])
+ }
+ else getGblEnv
+ }
+ where
-- | Generate bindings for the type representation of the wired-in TyCons defined
-- by the virtual "GHC.Prim" module. This differs from the usual
@@ -160,35 +201,50 @@ mkPrimTypeableBinds
-- "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)
+ghcPrimTypeableBinds :: TypeableStuff -> LHsBinds Id
+ghcPrimTypeableBinds stuff
+ = 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")
-
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
- )
+data TypeableStuff
+ = Stuff { dflags :: DynFlags
+ , mod_rep :: LHsExpr Id -- ^ Of type GHC.Types.Module
+ , pkg_str :: String -- ^ Package name
+ , mod_str :: String -- ^ Module name
+ , trTyConTyCon :: TyCon -- ^ of @TyCon@
+ , trTyConDataCon :: DataCon -- ^ of @TyCon@
+ , trNameLit :: FastString -> LHsExpr Id
+ -- ^ To construct @TrName@s
+ }
+
+-- | Collect various tidbits which we'll need to generate TyCon representations.
+collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff
+collect_stuff mod mod_rep = do
+ dflags <- getDynFlags
+ let pkg_str = unitIdString (moduleUnitId mod)
+ mod_str = moduleNameString (moduleName mod)
+
+ trTyConTyCon <- tcLookupTyCon trTyConTyConName
+ trTyConDataCon <- tcLookupDataCon trTyConDataConName
+ trNameLit <- mkTrNameLit
+ return Stuff {..}
+
+-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
+-- can save the work of repeating lookups when constructing many TyCon
+-- representations.
+mkTrNameLit :: TcM (FastString -> LHsExpr Id)
+mkTrNameLit = do
+ trNameSDataCon <- tcLookupDataCon trNameSDataConName
+ let trNameLit :: FastString -> LHsExpr Id
+ trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon)
+ [nlHsLit (mkHsStringPrimLit fs)]
+ return trNameLit
-- | Make bindings for the type representations of a 'TyCon' and its
-- promoted constructors.
@@ -196,28 +252,26 @@ mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
mk_typeable_binds stuff tycon
= mkTyConRepBinds stuff tycon
`unionBags`
- unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
+ unionManyBags (map (mkTyConRepBinds stuff . promoteDataCon)
+ (tyConDataCons tycon))
+-- | Make typeable bindings for the given 'TyCon'.
mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
-mkTyConRepBinds stuff tycon
+mkTyConRepBinds stuff@(Stuff {..}) tycon
= case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where
- rep_id = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon [])
+ rep_id = mkExportedVanillaId rep_name (mkTyConTy 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)
-
+-- | Produce the right-hand-side of a @TyCon@ representation.
mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
-mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
+mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
where
rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
[ nlHsLit (word64 high), nlHsLit (word64 low)
- , mod_expr
+ , mod_rep
, trNameLit (mkFastString tycon_str) ]
tycon_str = add_tick (occNameString (getOccName tycon))
@@ -232,4 +286,3 @@ mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
word64 :: Word64 -> HsLit
word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
| otherwise = \n -> HsWordPrim (show n) (toInteger n)
-
diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs
index dc6c0f5c90..a1aea0b000 100644
--- a/libraries/ghc-prim/GHC/Types.hs
+++ b/libraries/ghc-prim/GHC/Types.hs
@@ -344,7 +344,7 @@ data Levity = Lifted | Unlifted
{- *********************************************************************
* *
- Runtime represntation of TyCon
+ Runtime representation of TyCon
* *
********************************************************************* -}
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 935285a0d1..0d7127df0b 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -14,6 +14,11 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
T2431.$WRefl =
\ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a GHC.Prim.~# a)
+-- RHS size: {terms: 4, types: 8, coercions: 0}
+absurd :: forall a. Int :~: Bool -> a
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>x]
+absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
+
-- RHS size: {terms: 2, types: 0, coercions: 0}
a :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
@@ -53,10 +58,5 @@ T2431.$tc:~: =
GHC.Types.TyCon
9759653149176674453## 12942818337407067047## T2431.$trModule a3
--- RHS size: {terms: 4, types: 8, coercions: 0}
-absurd :: forall a. Int :~: Bool -> a
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>x]
-absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
-
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr
index 2282681a4a..cc62fa16e6 100644
--- a/testsuite/tests/ghci.debugger/scripts/print019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr
@@ -7,7 +7,7 @@
These potential instances exist:
instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’
instance Show Ordering -- Defined in ‘GHC.Show’
- instance Show Integer -- Defined in ‘GHC.Show’
+ instance Show TyCon -- Defined in ‘GHC.Show’
...plus 30 others
...plus 10 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr
index 31795bf90b..3bd9d88d41 100644
--- a/testsuite/tests/roles/should_compile/Roles13.stderr
+++ b/testsuite/tests/roles/should_compile/Roles13.stderr
@@ -2,81 +2,81 @@
==================== Tidy Core ====================
Result size of Tidy Core = {terms: 51, types: 20, coercions: 5}
+-- RHS size: {terms: 2, types: 2, coercions: 0}
+a :: Wrap Age -> Wrap Age
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
+a = \ (ds :: Wrap Age) -> ds
+
+-- RHS size: {terms: 1, types: 0, coercions: 5}
+convert :: Wrap Age -> Int
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
+convert =
+ a
+ `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0]
+ :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
+
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a :: GHC.Types.TrName
+a1 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a = GHC.Types.TrNameS "main"#
+a1 = GHC.Types.TrNameS "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a1 :: GHC.Types.TrName
+a2 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a1 = GHC.Types.TrNameS "Roles13"#
+a2 = GHC.Types.TrNameS "Roles13"#
-- RHS size: {terms: 3, types: 0, coercions: 0}
Roles13.$trModule :: GHC.Types.Module
[GblId, Caf=NoCafRefs, Str=DmdType]
-Roles13.$trModule = GHC.Types.Module a a1
+Roles13.$trModule = GHC.Types.Module a1 a2
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a2 :: GHC.Types.TrName
+a3 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a2 = GHC.Types.TrNameS "'MkAge"#
+a3 = GHC.Types.TrNameS "'MkAge"#
-- RHS size: {terms: 5, types: 0, coercions: 0}
Roles13.$tc'MkAge :: GHC.Types.TyCon
[GblId, Caf=NoCafRefs, Str=DmdType]
Roles13.$tc'MkAge =
GHC.Types.TyCon
- 1226019810264079099## 12180888342844277416## Roles13.$trModule a2
+ 1226019810264079099## 12180888342844277416## Roles13.$trModule a3
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a3 :: GHC.Types.TrName
+a4 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a3 = GHC.Types.TrNameS "Age"#
+a4 = GHC.Types.TrNameS "Age"#
-- RHS size: {terms: 5, types: 0, coercions: 0}
Roles13.$tcAge :: GHC.Types.TyCon
[GblId, Caf=NoCafRefs, Str=DmdType]
Roles13.$tcAge =
GHC.Types.TyCon
- 18304088376370610314## 1954648846714895105## Roles13.$trModule a3
+ 18304088376370610314## 1954648846714895105## Roles13.$trModule a4
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a4 :: GHC.Types.TrName
+a5 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a4 = GHC.Types.TrNameS "'MkWrap"#
+a5 = GHC.Types.TrNameS "'MkWrap"#
-- RHS size: {terms: 5, types: 0, coercions: 0}
Roles13.$tc'MkWrap :: GHC.Types.TyCon
[GblId, Caf=NoCafRefs, Str=DmdType]
Roles13.$tc'MkWrap =
GHC.Types.TyCon
- 12402878715225676312## 13345418993613492500## Roles13.$trModule a4
+ 12402878715225676312## 13345418993613492500## Roles13.$trModule a5
-- RHS size: {terms: 2, types: 0, coercions: 0}
-a5 :: GHC.Types.TrName
+a6 :: GHC.Types.TrName
[GblId, Caf=NoCafRefs, Str=DmdType]
-a5 = GHC.Types.TrNameS "Wrap"#
+a6 = GHC.Types.TrNameS "Wrap"#
-- RHS size: {terms: 5, types: 0, coercions: 0}
Roles13.$tcWrap :: GHC.Types.TyCon
[GblId, Caf=NoCafRefs, Str=DmdType]
Roles13.$tcWrap =
GHC.Types.TyCon
- 5278920226786541118## 14554440859491798587## Roles13.$trModule a5
-
--- RHS size: {terms: 2, types: 2, coercions: 0}
-a6 :: Wrap Age -> Wrap Age
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
-a6 = \ (ds :: Wrap Age) -> ds
-
--- RHS size: {terms: 1, types: 0, coercions: 5}
-convert :: Wrap Age -> Int
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
-convert =
- a6
- `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0]
- :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
+ 5278920226786541118## 14554440859491798587## Roles13.$trModule a6
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index ac570df364..b96512c471 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -21,6 +21,58 @@ T7360.$WFoo3 =
T7360.Foo3 dt
}
+-- RHS size: {terms: 5, types: 2, coercions: 0}
+fun1 [InlPrag=NOINLINE] :: Foo -> ()
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
+fun1 =
+ \ (x :: Foo) ->
+ case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+T7360.fun5 :: ()
+[GblId,
+ Str=DmdType,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
+T7360.fun5 = fun1 T7360.Foo1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+T7360.fun4 :: Int
+[GblId,
+ Caf=NoCafRefs,
+ Str=DmdType m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.fun4 = GHC.Types.I# 0#
+
+-- RHS size: {terms: 16, types: 13, coercions: 0}
+fun2 :: forall a. [a] -> ((), Int)
+[GblId,
+ Arity=1,
+ Str=DmdType <L,1*U>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
+ (T7360.fun5,
+ case x of wild {
+ [] -> T7360.fun4;
+ : _ [Occ=Dead] _ [Occ=Dead] ->
+ case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
+ GHC.Types.I# ww2
+ }
+ })}]
+fun2 =
+ \ (@ a) (x :: [a]) ->
+ (T7360.fun5,
+ case x of wild {
+ [] -> T7360.fun4;
+ : ds ds1 ->
+ case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
+ GHC.Types.I# ww2
+ }
+ })
+
-- RHS size: {terms: 2, types: 0, coercions: 0}
T7360.$trModule2 :: GHC.Types.TrName
[GblId,
@@ -141,57 +193,5 @@ T7360.$tcFoo =
T7360.$trModule
T7360.$tcFoo1
--- RHS size: {terms: 5, types: 2, coercions: 0}
-fun1 [InlPrag=NOINLINE] :: Foo -> ()
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
-fun1 =
- \ (x :: Foo) ->
- case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() }
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.fun5 :: ()
-[GblId,
- Str=DmdType,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
-T7360.fun5 = fun1 T7360.Foo1
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.fun4 :: Int
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
-T7360.fun4 = GHC.Types.I# 0#
-
--- RHS size: {terms: 16, types: 13, coercions: 0}
-fun2 :: forall a. [a] -> ((), Int)
-[GblId,
- Arity=1,
- Str=DmdType <L,1*U>m,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
- (T7360.fun5,
- case x of wild {
- [] -> T7360.fun4;
- : _ [Occ=Dead] _ [Occ=Dead] ->
- case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
- GHC.Types.I# ww2
- }
- })}]
-fun2 =
- \ (@ a) (x :: [a]) ->
- (T7360.fun5,
- case x of wild {
- [] -> T7360.fun4;
- : ds ds1 ->
- case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
- GHC.Types.I# ww2
- }
- })
-
diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout
index 05a0069720..43830c7135 100644
--- a/testsuite/tests/simplCore/should_compile/T8274.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8274.stdout
@@ -1,3 +1,5 @@
+p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
+n = T8274.Negatives -4# -4.0# -4.0##
T8274.$trModule2 = GHC.Types.TrNameS "main"#
T8274.$trModule1 = GHC.Types.TrNameS "T8274"#
T8274.$tc'Positives1 = GHC.Types.TrNameS "'Positives"#
@@ -8,5 +10,3 @@ T8274.$tc'Negatives1 = GHC.Types.TrNameS "'Negatives"#
T8274.$tc'Negatives = GHC.Types.TyCon 15950179315687996644## 11481167534507418130## T8274.$trModule T8274.$tc'Negatives1
T8274.$tcN1 = GHC.Types.TrNameS "N"#
T8274.$tcN = GHC.Types.TyCon 7479687563082171902## 17616649989360543185## T8274.$trModule T8274.$tcN1
-p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
-n = T8274.Negatives -4# -4.0# -4.0##
diff --git a/testsuite/tests/stranal/should_compile/T10694.stdout b/testsuite/tests/stranal/should_compile/T10694.stdout
index 64d5f7a1aa..eaffa9446f 100644
--- a/testsuite/tests/stranal/should_compile/T10694.stdout
+++ b/testsuite/tests/stranal/should_compile/T10694.stdout
@@ -1,5 +1,5 @@
+[GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m]
+ Str=DmdType <L,U(U)><L,U(U)>,
Str=DmdType m1,
Str=DmdType m1,
Str=DmdType m,
-[GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m]
- Str=DmdType <L,U(U)><L,U(U)>,