diff options
author | Ben Gamari <bgamari.foss@gmail.com> | 2016-02-18 22:05:02 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2016-02-18 22:08:16 +0100 |
commit | 206a8bf4665af216784357f6741ccf5e68dd2495 (patch) | |
tree | cac5afabf84ac0c01f17a657966a2110e1078330 | |
parent | a008eadfaa4816be349b4fefde9b9b9edc1ca359 (diff) | |
download | haskell-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.hs | 22 | ||||
-rw-r--r-- | compiler/prelude/TysWiredIn.hs | 62 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 20 | ||||
-rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcTypeable.hs | 193 | ||||
-rw-r--r-- | libraries/ghc-prim/GHC/Types.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_compile/T2431.stderr | 10 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/print019.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/roles/should_compile/Roles13.stderr | 60 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T7360.stderr | 104 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T8274.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/stranal/should_compile/T10694.stdout | 4 |
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)>, |