Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 0a2dbd93 by Simon Peyton Jones at 2026-04-09T00:18:12+01:00 More - - - - - 16 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -177,7 +177,7 @@ wired in ones are defined in GHC.Builtin.Types etc. basicKnownKeyTable :: [(OccName, KnownKey)] basicKnownKeyTable - = [ (rationalTyConOcc, rationalTyConKey) + = [ (mkTcOcc "Read", readClassKey) , (mkTcOcc "Show", showClassKey) , (mkTcOcc "Foldable", foldableClassKey) , (mkTcOcc "Traversable", traversableClassKey) @@ -213,15 +213,22 @@ basicKnownKeyTable , (mkTcOcc "Real", realClassKey) , (mkTcOcc "Fractional", fractionalClassKey) , (mkTcOcc "RealFloat", realFloatClassKey) --- , (mkTcOcc "RealFrac", realFracClassKey) + , (mkTcOcc "RealFrac", realFracClassKey) , (mkVarOcc "-", minusClassOpKey) , (mkVarOcc "negate", negateClassOpKey) , (mkVarOcc "fromInteger", fromIntegerClassOpKey) + , (mkVarOcc "divInt#", divIntIdKey) + , (mkVarOcc "modInt#", modIntIdKey) + + , (mkTcOcc "Ratio", ratioTyConKey) + , (mkDataOcc ":%", ratioDataConKey) + , (mkVarOcc "fromIntegral", fromIntegralIdKey) , (mkVarOcc "fromRational", fromRationalClassOpKey) + , (mkVarOcc "toInteger", toIntegerClassOpKey) + , (mkVarOcc "toRational", toRationalClassOpKey) + , (mkVarOcc "realToFrac", realToFracIdKey) , (mkVarOcc "mkRationalBase2", mkRationalBase2IdKey) , (mkVarOcc "mkRationalBase10", mkRationalBase10IdKey) - , (mkVarOcc "divInt#", divIntIdKey) - , (mkVarOcc "modInt#", modIntIdKey) -- Class Functor , (mkTcOcc "Functor", functorClassKey) @@ -297,19 +304,23 @@ basicKnownKeyTable , (mkVarOcc "fromStaticPtr", fromStaticPtrClassOpKey) , (mkVarOcc "makeStatic", makeStaticKey) + -- WithDict + , (mkTcOcc "WithDict", withDictClassKey) + -- Unsatisfiable class , (mkTcOcc "Unsatisfiable", unsatisfiableClassKey) , (mkVarOcc "unsatisfiable", unsatisfiableIdKey) + -- Known-key names that have BuiltinRules in ConstantFold , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) , (mkVarOcc "unpackFoldrCStringUtf8#", unpackCStringFoldrUtf8IdKey) , (mkVarOcc "unpackAppendCString#", unpackCStringAppendIdKey) , (mkVarOcc "unpackAppendCStringUtf8#", unpackCStringAppendUtf8IdKey) , (mkVarOcc "cstringLength#", cstringLengthIdKey) - , (mkVarOcc "eqString", eqStringIdKey) , (mkVarOcc "inline", inlineIdKey) + , (mkVarOcc "seq#", seqHashKey) -- Unsafe equality proofs , (mkVarOcc "unsafeEqualityProof", unsafeEqualityProofIdKey) @@ -387,60 +398,19 @@ basicKnownKeyNames runMainIOName, runRWName, - -- Type representation types - trModuleTyConName, trModuleDataConName, - trNameSDataConName, - trTyConTyConName, trTyConDataConName, - - -- Typeable - someTypeRepTyConName, -- known-occ - someTypeRepDataConName, -- ditto - kindRepTyConName, - kindRepTyConAppDataConName, - kindRepVarDataConName, - kindRepAppDataConName, - kindRepFunDataConName, - kindRepTYPEDataConName, - kindRepTypeLitSDataConName, - typeLitSymbolDataConName, - typeLitNatDataConName, - typeLitCharDataConName, - typeRepIdName, - mkTrConName, - mkTrAppCheckedName, - mkTrFunName, - typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName, - trGhcPrimModuleName, - -- KindReps for common cases + trGhcPrimModuleName, starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, constraintKindRepName, - -- WithDict - withDictClassName, - - -- seq# - seqHashName, - - -- Dynamic - toDynName, - - -- Conversion functions - ratioTyConName, ratioDataConName, - toIntegerName, toRationalName, - fromIntegralName, realToFracName, - -- String stuff fromStringName, -- Monad stuff bindMName, - -- Read stuff - readClassName, - -- Stable pointers newStablePtrName, @@ -871,17 +841,6 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key --------------------------------- -- GHC.Internal.Real types and classes -ratioTyConName, ratioDataConName, - fromRationalName, toIntegerName, toRationalName, fromIntegralName, - realToFracName :: Name -ratioTyConName = tcQual gHC_INTERNAL_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = dcQual gHC_INTERNAL_REAL (fsLit ":%") ratioDataConKey -fromRationalName = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = varQual gHC_INTERNAL_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = varQual gHC_INTERNAL_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey -realToFracName = varQual gHC_INTERNAL_REAL (fsLit "realToFrac") realToFracIdKey - -- other GHC.Internal.Float functions integerToFloatName, integerToDoubleName, rationalToFloatName, rationalToDoubleName :: Name @@ -890,71 +849,12 @@ integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") int rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat#") rationalToFloatIdKey rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble#") rationalToDoubleIdKey --- Typeable representation types -trModuleTyConName - , trModuleDataConName - , trNameSDataConName - , trTyConTyConName - , trTyConDataConName - :: Name -trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey -trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey -trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey -trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey -trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey - -kindRepTyConName - , kindRepTyConAppDataConName - , kindRepVarDataConName - , kindRepAppDataConName - , kindRepFunDataConName - , kindRepTYPEDataConName - , kindRepTypeLitSDataConName - :: Name -kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey -kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey -kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey -kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey -kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey -kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey -kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey - -typeLitSymbolDataConName - , typeLitNatDataConName - , typeLitCharDataConName - :: Name -typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey -typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey -typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey - -- Class Typeable, and functions for constructing `Typeable` dictionaries -someTypeRepTyConName - , someTypeRepDataConName - , mkTrConName - , mkTrAppCheckedName - , mkTrFunName - , typeRepIdName - , typeNatTypeRepName - , typeSymbolTypeRepName - , typeCharTypeRepName - , trGhcPrimModuleName - :: Name -someTypeRepTyConName = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey -someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey -typeRepIdName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey -mkTrConName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey -mkTrAppCheckedName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey -mkTrFunName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey -typeNatTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey -typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey -typeCharTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey --- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) +trGhcPrimModuleName, starKindRepName, starArrStarKindRepName, + starArrStarArrStarKindRepName, constraintKindRepName :: Name +-- 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 GHC.Tc.Instance.Typeable. trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey - --- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, - starArrStarArrStarKindRepName, constraintKindRepName :: Name starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey @@ -967,10 +867,6 @@ withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey nonEmptyTyConName :: Name nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey --- seq# -seqHashName :: Name -seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey - -- Custom type errors errorMessageTypeErrorFamName , typeErrorTextDataConName @@ -998,10 +894,6 @@ typeErrorShowTypeDataConName = unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey --- Dynamic -toDynName :: Name -toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey - -- Error module assertErrorName :: Name assertErrorName = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey @@ -1010,10 +902,6 @@ assertErrorName = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") asse traceName :: Name traceName = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey --- Class Read -readClassName :: Name -readClassName = clsQual gHC_INTERNAL_READ (fsLit "Read") readClassKey - genericClassKeys :: [KnownKey] genericClassKeys = [genClassKey, gen1ClassKey] @@ -1157,9 +1045,6 @@ dcQual modu str unique = mk_known_key_name dataName modu str unique * * ********************************************************************* -} -rationalTyConOcc :: KnownOcc -rationalTyConOcc = mkTcOcc "Rational" - sappendClassOpOcc, pureAClassOpOcc, thenAClassOpOcc, returnMClassOpOcc, thenMClassOpOcc, mappendClassOpOcc :: KnownOcc sappendClassOpOcc = mkVarOcc "<>" ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -21,6 +21,8 @@ import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Builtin.TH( unsafeCodeCoerceName, liftTypedName ) import GHC.Builtin.KnownKeys +import GHC.Types.Name( KnownOcc ) +import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader( RdrName, mkVarUnqual, getRdrName , nameRdrName ) import GHC.Types.Id.Make( coerceName ) -- `coerce` is wired-in @@ -48,6 +50,85 @@ mechanisms: -} +{- ********************************************************************* +* * + Known-occ OccNames +* * +********************************************************************* -} + +rationalTyConOcc :: KnownOcc +rationalTyConOcc = mkTcOcc "Rational" + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +someTypeRepTyConOcc + , someTypeRepDataConOcc + , mkTrConOcc + , mkTrAppCheckedOcc + , mkTrFunOcc + , typeRepIdOcc + , typeNatTypeRepOcc + , typeSymbolTypeRepOcc + , typeCharTypeRepOcc + :: KnownOcc +someTypeRepTyConOcc = mkTcOcc "SomeTypeRep" +someTypeRepDataConOcc = mkDataOcc "SomeTypeRep" +typeRepIdOcc = mkVarOcc "typeRep#" +mkTrConOcc = mkVarOcc "mkTrCon" +mkTrAppCheckedOcc = mkVarOcc "mkTrAppChecked" +mkTrFunOcc = mkVarOcc "mkTrFun" +typeNatTypeRepOcc = mkVarOcc "typeNatTypeRep" +typeSymbolTypeRepOcc = mkVarOcc "typeSymbolTypeRep" +typeCharTypeRepOcc = mkVarOcc "typeCharTypeRep" + +typeLitSymbolDataConOcc + , typeLitNatDataConOcc + , typeLitCharDataConOcc + :: KnownOcc +typeLitSymbolDataConOcc = mkDataOcc "TypeLitSymbol" +typeLitNatDataConOcc = mkDataOcc "TypeLitNat" +typeLitCharDataConOcc = mkDataOcc "TypeLitChar" + + +trModuleTyConOcc + , trModuleDataConOcc + , trNameSDataConOcc + , trTyConTyConOcc + , trTyConDataConOcc + :: KnownOcc +trModuleTyConOcc = mkTcOcc "Module" +trModuleDataConOcc = mkDataOcc "Module" +trNameSDataConOcc = mkDataOcc "TrNameS" +trTyConTyConOcc = mkTcOcc "TyCon" +trTyConDataConOcc = mkDataOcc "TyCon" + +-- Typeable representation types +kindRepTyConOcc + , kindRepTyConAppDataConOcc + , kindRepVarDataConOcc + , kindRepAppDataConOcc + , kindRepFunDataConOcc + , kindRepTYPEDataConOcc + , kindRepTypeLitSDataConOcc + :: KnownOcc +kindRepTyConOcc = mkTcOcc "KindRep" +kindRepTyConAppDataConOcc = mkDataOcc "KindRepTyConApp" +kindRepVarDataConOcc = mkDataOcc "KindRepVar" +kindRepAppDataConOcc = mkDataOcc "KindRepApp" +kindRepFunDataConOcc = mkDataOcc "KindRepFun" +kindRepTYPEDataConOcc = mkDataOcc "KindRepTYPE" +kindRepTypeLitSDataConOcc = mkDataOcc "KindRepTypeLitS" + + +{- ********************************************************************* +* * + Misc global RdrNames +* * +********************************************************************* -} + +toDyn_RDR :: RdrName +toDyn_RDR = knownVarOccRdrName "toDyn" + + {- ********************************************************************* * * Global RdrNames used by derived instances ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -58,7 +58,8 @@ import GHC.Core.Rules import GHC.Core.Ppr( pprCoreBinders ) import GHC.Core.TyCo.Compare( eqType ) -import GHC.Builtin.KnownKeys +import GHC.Builtin.KnownKeys( typeableClassKey ) +import GHC.Builtin.KnownOccs import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) import GHC.Tc.Types.Evidence @@ -1761,10 +1762,10 @@ type TypeRepExpr = CoreExpr -- | Returns a @CoreExpr :: TypeRep ty@ ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName + = do { mkTrCon <- dsLookupKnownOccId mkTrConOcc -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + ; someTypeRepTyCon <- dsLookupKnownOccTyCon someTypeRepTyConOcc + ; someTypeRepDataCon <- dsLookupKnownOccDataCon someTypeRepDataConOcc -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep ; tc_rep <- tyConRep tc -- :: TyCon @@ -1793,7 +1794,7 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) | Just (t1,t2) <- splitAppTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 - ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName + ; mkTrAppChecked <- dsLookupKnownOccId mkTrAppCheckedOcc -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, @@ -1809,7 +1810,7 @@ ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 ; em <- getRep evm m - ; mkTrFun <- dsLookupGlobalId mkTrFunName + ; mkTrFun <- dsLookupKnownOccId mkTrFunOcc -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b) ; let r1 = getRuntimeRep t1 @@ -1820,7 +1821,7 @@ ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) ds_ev_typeable ty (EvTypeableTyLit ev) = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class - do { fun <- dsLookupGlobalId tr_fun + do { fun <- dsLookupKnownOccId tr_fun ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) } where @@ -1829,9 +1830,9 @@ ds_ev_typeable ty (EvTypeableTyLit ev) -- tr_fun is the Name of -- typeNatTypeRep :: KnownNat a => TypeRep a -- of typeSymbolTypeRep :: KnownSymbol a => TypeRep a - tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepName - | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName - | ty_kind `eqType` charTy = typeCharTypeRepName + tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepOcc + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepOcc + | ty_kind `eqType` charTy = typeCharTypeRepOcc | otherwise = panic "dsEvTypeable: unknown type lit kind" ds_ev_typeable ty ev @@ -1845,7 +1846,7 @@ getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ -- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a getRep ev ty = do { typeable_expr <- dsEvTerm ev - ; typeRepId <- dsLookupGlobalId typeRepIdName + ; typeRepId <- dsLookupKnownOccId typeRepIdOcc ; let ty_args = [typeKind ty, ty] ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -238,7 +238,7 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = b dsRational :: Rational -> DsM CoreExpr dsRational (n :% d) = do platform <- targetPlatform <$> getDynFlags - dcn <- dsLookupDataCon ratioDataConName + dcn <- dsLookupKnownKeyDataCon ratioDataConKey let cn = mkIntegerExpr platform n let dn = mkIntegerExpr platform d return $ mkCoreConApps dcn [Type integerTy, cn, dn] ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -27,9 +27,9 @@ module GHC.HsToCore.Monad ( -- Looking up in the environment dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, - dsLookupKnownKeyTyCon, dsLookupKnownKeyId, + dsLookupKnownKeyTyCon, dsLookupKnownKeyDataCon, dsLookupKnownKeyId, dsLookupKnownKeyName, - dsLookupKnownOccId, dsLookupKnownOccTyCon, + dsLookupKnownOccId, dsLookupKnownOccTyCon, dsLookupKnownOccDataCon, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, @@ -597,6 +597,9 @@ dsLookupKnownOccThing occ dsLookupKnownOccTyCon :: KnownOcc -> DsM TyCon dsLookupKnownOccTyCon uniq = tyThingTyCon <$> dsLookupKnownOccThing uniq +dsLookupKnownOccDataCon :: KnownOcc -> DsM DataCon +dsLookupKnownOccDataCon uniq = tyThingDataCon <$> dsLookupKnownOccThing uniq + dsLookupKnownOccId :: KnownOcc -> DsM Id dsLookupKnownOccId uniq = tyThingId <$> dsLookupKnownOccThing uniq @@ -624,6 +627,9 @@ dsLookupKnownKeyThing uniq dsLookupKnownKeyTyCon :: KnownKey -> DsM TyCon dsLookupKnownKeyTyCon uniq = tyThingTyCon <$> dsLookupKnownKeyThing uniq +dsLookupKnownKeyDataCon :: KnownKey -> DsM DataCon +dsLookupKnownKeyDataCon uniq = tyThingDataCon <$> dsLookupKnownKeyThing uniq + dsLookupKnownKeyId :: KnownKey -> DsM Id dsLookupKnownKeyId uniq = tyThingId <$> dsLookupKnownKeyThing uniq ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -21,7 +21,8 @@ import GHC.Types.Id import GHC.Core.ConLike import GHC.Types.Name import GHC.Builtin.Types -import GHC.Builtin.KnownKeys (rationalTyConKey, toListClassOpKey) +import GHC.Builtin.KnownKeys ( toListClassOpKey ) +import GHC.Builtin.KnownOccs ( rationalTyConOcc ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -253,7 +254,7 @@ desugarPat x pat = case pat of , (HsFractional f) <- val , negates <- if fl_neg f then 1 else 0 -> do - rat_tc <- dsLookupKnownKeyTyCon rationalTyConKey + rat_tc <- dsLookupKnownOccTyCon rationalTyConOcc let rat_ty = mkTyConTy rat_tc return $ Just $ PmLit rat_ty (PmLitOverRat negates f) | otherwise ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Builtin.KnownKeys ( toDynName ) +import GHC.Builtin.KnownOccs ( toDyn_RDR ) import GHC.Builtin.Types ( pretendNameIsInScope ) import GHC.Data.Maybe @@ -1290,7 +1290,7 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . mkHsVar . L (l2l loc) $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . mkHsVar . L (l2l loc) toDyn_RDR) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce hval :: Dynamic) ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -443,7 +443,7 @@ matchWithDict [cls_ty, mty] , [inst_meth_ty] <- dataConInstArgTys dict_dc dict_args = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty openAlphaTy) - ; wd_cls <- tcLookupClass withDictClassName + ; wd_cls <- tcLookupKnownKeyClass withDictClassKey -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of -- the WithDict dictionary: ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -12,32 +12,41 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( TypeOrConstraint(..) ) -import GHC.Types.InlinePragma ( neverInlinePragma ) -import GHC.Types.SourceText ( SourceText(..) ) -import GHC.Iface.Env( newGlobalBinder ) -import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) +import GHC.Hs + import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence ( mkWpTyApps ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Types.TyThing ( lookupId ) + +import GHC.Iface.Env( newGlobalBinder ) + import GHC.Builtin.KnownKeys +import GHC.Builtin.KnownOccs import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types ( runtimeRepTyCon , levityTyCon, vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) + +import GHC.Types.TyThing ( lookupId ) +import GHC.Types.Basic ( TypeOrConstraint(..) ) +import GHC.Types.InlinePragma ( neverInlinePragma ) +import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.Name import GHC.Types.Id +import GHC.Types.Var ( VarBndr(..) ) + +import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.DataCon +import GHC.Core.Map.Type + import GHC.Unit.Module -import GHC.Hs + import GHC.Driver.DynFlags -import GHC.Types.Var ( VarBndr(..) ) -import GHC.Core.Map.Type + import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -342,7 +351,7 @@ mkModIdBindings = do { mod <- getModule ; loc <- getSrcSpanM ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) Nothing loc - ; trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; trModuleTyCon <- tcLookupKnownOccTyCon trModuleTyConOcc ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) `setInlinePragma` neverInlinePragma -- See Note [NOINLINE on generated Typeable bindings] @@ -354,7 +363,7 @@ mkModIdBindings mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) mkModIdRHS mod - = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName + = do { trModuleDataCon <- tcLookupKnownOccDataCon trModuleDataConOcc ; trNameLit <- mkTrNameLit ; return $ nlHsDataCon trModuleDataCon `nlHsApp` trNameLit (unitFS (moduleUnit mod)) @@ -393,7 +402,7 @@ data TyConTodo todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName + trTyConTy <- mkTyConTy <$> tcLookupKnownOccTyCon trTyConTyConOcc let mk_rep_id :: TyConRepName -> Id mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy `setInlinePragma` neverInlinePragma @@ -426,7 +435,7 @@ todoForTyCons mod mod_id tycons = do todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo todoForExportedKindReps kinds = do - trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName + trKindRepTy <- mkTyConTy <$> tcLookupKnownOccTyCon kindRepTyConOcc let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) return $ ExportedKindRepsTodo $ map mkId kinds @@ -472,7 +481,7 @@ mkPrimTypeableTodos = do { mod <- getModule ; if mod == gHC_TYPES then do { -- Build Module binding for GHC.Prim - trModuleTyCon <- tcLookupTyCon trModuleTyConName + trModuleTyCon <- tcLookupKnownOccTyCon trModuleTyConOcc ; let ghc_prim_module_id = mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon) @@ -547,17 +556,17 @@ data TypeableStuff collect_stuff :: TcM TypeableStuff collect_stuff = do platform <- targetPlatform <$> getDynFlags - trTyConDataCon <- tcLookupDataCon trTyConDataConName - kindRepTyCon <- tcLookupTyCon kindRepTyConName - kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName - kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName - kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName - kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName - kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName - kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName - typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName - typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName - typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName + trTyConDataCon <- tcLookupKnownOccDataCon trTyConDataConOcc + kindRepTyCon <- tcLookupKnownOccTyCon kindRepTyConOcc + kindRepTyConAppDataCon <- tcLookupKnownOccDataCon kindRepTyConAppDataConOcc + kindRepVarDataCon <- tcLookupKnownOccDataCon kindRepVarDataConOcc + kindRepAppDataCon <- tcLookupKnownOccDataCon kindRepAppDataConOcc + kindRepFunDataCon <- tcLookupKnownOccDataCon kindRepFunDataConOcc + kindRepTYPEDataCon <- tcLookupKnownOccDataCon kindRepTYPEDataConOcc + kindRepTypeLitSDataCon <- tcLookupKnownOccDataCon kindRepTypeLitSDataConOcc + typeLitSymbolDataCon <- tcLookupKnownOccDataCon typeLitSymbolDataConOcc + typeLitNatDataCon <- tcLookupKnownOccDataCon typeLitNatDataConOcc + typeLitCharDataCon <- tcLookupKnownOccDataCon typeLitCharDataConOcc trNameLit <- mkTrNameLit return Stuff {..} @@ -566,7 +575,7 @@ collect_stuff = do -- representations. mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) mkTrNameLit = do - trNameSDataCon <- tcLookupDataCon trNameSDataConName + trNameSDataCon <- tcLookupKnownOccDataCon trNameSDataConOcc let trNameLit :: FastString -> LHsExpr GhcTc trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon `nlHsApp` nlHsLit (mkHsStringPrimLit fs) ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -31,7 +31,7 @@ module GHC.Tc.Utils.Env( tcLookupKnownKeyGlobal, tcLookupKnownKeyTyCon, tcLookupKnownKeyClass, tcLookupKnownKeyId, - tcLookupKnownOccTyCon, tcLookupKnownOccId, + tcLookupKnownOccTyCon, tcLookupKnownOccDataCon, tcLookupKnownOccId, rnLookupKnownKeyName, rnLookupKnownKeyRdr, getKnownKeySource, -- Local environment @@ -304,11 +304,7 @@ tcLookupGlobalOnly name Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name = do - thing <- tcLookupGlobal name - case thing of - AConLike (RealDataCon con) -> return con - _ -> wrongThingErr WrongThingDataCon (AGlobal thing) name +tcLookupDataCon = get_datacon . tcLookupGlobal tcLookupPatSyn :: Name -> TcM PatSyn tcLookupPatSyn name = do @@ -337,18 +333,10 @@ tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons = cons }) -- Any constructor will give the same result here. tcLookupClass :: Name -> TcM Class -tcLookupClass name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr WrongThingClass (AGlobal thing) name +tcLookupClass = get_class . tcLookupGlobal tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc -> return tc - _ -> wrongThingErr WrongThingTyCon (AGlobal thing) name +tcLookupTyCon = get_tycon . tcLookupGlobal tcLookupAxiom :: Name -> TcM (CoAxiom Branched) tcLookupAxiom name = do @@ -573,6 +561,9 @@ tcLookupKnownOccGlobal = tcrn_wrapper . lookupKnownOccThing tcLookupKnownOccTyCon :: HasDebugCallStack => KnownOcc -> TcM TyCon tcLookupKnownOccTyCon = get_tycon . tcLookupKnownOccGlobal +tcLookupKnownOccDataCon :: HasDebugCallStack => KnownOcc -> TcM DataCon +tcLookupKnownOccDataCon = get_datacon . tcLookupKnownOccGlobal + tcLookupKnownOccId :: HasDebugCallStack => KnownOcc -> TcM Id tcLookupKnownOccId = get_id . tcLookupKnownOccGlobal @@ -592,6 +583,13 @@ get_tycon do_the_lookup ATyCon tc -> return tc _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } +get_datacon :: TcRn TyThing -> TcRn DataCon +get_datacon do_the_lookup + = do { thing <- do_the_lookup + ; case thing of + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } + get_id :: TcRn TyThing -> TcRn Id get_id do_the_lookup = do { thing <- do_the_lookup ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -40,7 +40,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env -import GHC.Builtin.KnownKeys( rationalTyConOcc ) +import GHC.Builtin.KnownOccs( rationalTyConOcc ) import GHC.Builtin.Types( integerTy ) import GHC.Hs ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -11,8 +11,7 @@ -- module GHC.KnownKeyNames - ( Rational - , Eq(..), Ord(..) -- With their methods + ( Eq(..), Ord(..) -- With their methods , Show, Read , Foldable, Traversable , Functor, fmap @@ -21,6 +20,7 @@ module GHC.KnownKeyNames -- Misc , (.), (&&), not, map, foldr, build + , seq# -- Applicative , Applicative, pure, mzip, (<*>), (*>) @@ -61,10 +61,14 @@ module GHC.KnownKeyNames -- Numbers , Num, Integral, Real, Fractional, RealFloat , (+), (-), (*), negate, fromInteger - , fromRational - , mkRationalBase2, mkRationalBase10 , divInt#, modInt# + , Ratio( (:%) ), Rational + , mkRationalBase2, mkRationalBase10 + , toInteger, toRational + , fromIntegral, fromRational + , realToFrac + -- Strings , IsString , fromString @@ -82,6 +86,9 @@ module GHC.KnownKeyNames -- IO , IO, thenIO, bindIO, returnIO, print + -- WithDict + , WithDict + -- Unsatisfiable , Unsatisfiable, unsatisfiable @@ -95,6 +102,15 @@ module GHC.KnownKeyNames , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof + -- Typeable and type representations + , SomeTypeRep( SomeTypeRep ), Module( Module ) + , TyCon( TyCon ), TrName( TrNameS ) + , KindRep( KindRepTyConApp, KindRepVar, KindRepApp, KindREpFun, KindRepTYPE, KindREpTypeLitS ) + , typeLitSort( TypeLitSymbol, TypeLitNat, TypeLitChar ) + , typeRep# + , mkTrCon, mkTrAppChecked, mkTrFun + , typeNatTypeRep, typeSymbolTypeRep, typeCharTypeRep + -- Bignums , bigNatEq#, bigNatCompare, bigNatCompareWord# , naturalToWord#, naturalPopCount#, naturalShiftR#, naturalShiftL# @@ -153,13 +169,15 @@ import Data.String( IsString ) import GHC.Internal.Base import GHC.Internal.Ix import GHC.Internal.Magic( inline ) +import GHC.Internal.Magic.Dict( WithDict ) import GHC.Internal.Enum +import GHC.Internal.Dynamic( toDyn ) import GHC.Internal.Data.Data import GHC.Internal.Data.String( fromString ) import GHC.Internal.Data.Foldable( Foldable ) import GHC.Internal.Data.Traversable( Traversable ) import GHC.Internal.Float( RealFloat ) -import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) +import GHC.Internal.Real import GHC.Internal.Control.Monad( fail, guard ) import GHC.Internal.Control.Monad.Fix( mfix, loop ) import GHC.Internal.Control.Monad.Zip( mzip ) @@ -177,6 +195,7 @@ import GHC.Internal.StaticPtr( IsStatic(..) ) import GHC.Internal.StaticPtr.Internal( makeStatic ) import GHC.Internal.Data.Typeable( Typeable, gcast1, gcast2 ) +import GHC.Internal.Data.Typeable.Internal import GHC.Internal.Generics import GHC.Internal.Bignum.BigNat ===================================== libraries/ghc-internal/src/GHC/Internal/IO.hs ===================================== @@ -6,6 +6,10 @@ , ScopedTypeVariables , UnboxedTuples #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines seq# + {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -1,5 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines Read + {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Real.hs ===================================== @@ -2,7 +2,7 @@ {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-} {-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines Real, Integral etc, etc, etc + -- Defines Real, Integral, Ratio etc, etc, etc {-# OPTIONS_GHC -Wno-orphans #-} ===================================== libraries/ghc-internal/src/GHC/Internal/Types.hs ===================================== @@ -4,7 +4,9 @@ TypeApplications, StandaloneKindSignatures, GADTs, FlexibleInstances, UndecidableInstances, UnboxedSums #-} -- NegativeLiterals: see Note [Fixity of (->)] + {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a2dbd93fbd9d850b15d079f70ac0211... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a2dbd93fbd9d850b15d079f70ac0211... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Simon Peyton Jones (＠simonpj)