Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 9c334c51 by Rodrigo Mesquita at 2026-05-05T16:09:19+01:00 fixup krep fixes TODO GET BACK - - - - - 5f335b6e by Rodrigo Mesquita at 2026-05-05T16:09:25+01:00 Revert "fixup krep fixes" This reverts commit 0c3177e9ecfdd9444df3439744996d599cb64c9b. TODO GET BACK - - - - - 9462a047 by Rodrigo Mesquita at 2026-05-05T16:09:28+01:00 Revert "krepStar, krepStarArrStar, etc..." This reverts commit a47d441c70e2650cd7c6a4d466ec57c311ebe329. TODO TODO TODO. Thinking a bit more about this. get back later. - - - - - bf30dcb3 by Rodrigo Mesquita at 2026-05-05T16:27:07+01:00 emptyCallStack - - - - - f6e3662f by Rodrigo Mesquita at 2026-05-05T16:31:30+01:00 misc fixes to build - - - - - 7f109c42 by Rodrigo Mesquita at 2026-05-05T16:55:20+01:00 callStackTyConKey, exceptionContextTyConKey, emptyExceptionContextName - - - - - d26b5b42 by Rodrigo Mesquita at 2026-05-05T17:10:49+01:00 errorMessageTypeErrorFamName, typeErrorTextDataConName, typeErrorAppendDataConName, typeErrorVAppendDataConName, typeErrorShowTypeDataConName - - - - - b7ce4338 by Rodrigo Mesquita at 2026-05-05T17:31:44+01:00 staticPtrTyConName, staticPtrDataConName, staticPtrInfoDataConName - - - - - 7adf8b47 by Rodrigo Mesquita at 2026-05-05T17:31:44+01:00 -jsvalTyConName - - - - - e354bdae by Rodrigo Mesquita at 2026-05-05T17:31:44+01:00 knownNatClassName, knownSymbolClassName, knownCharClassName - - - - - a207cbcf by Rodrigo Mesquita at 2026-05-05T17:33:22+01:00 unsafeUnpackJSStringUtf8## - - - - - 20 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - ghc/GHCi/UI.hs - libraries/base/src/GHC/Essentials.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -253,10 +253,26 @@ knownKeyTable -- Implicit Params , (mkTcOcc "IP", ipClassKey) + -- Callstacks + , (mkVarOcc "CallStack", callStackTyConKey) + + -- Exception context + , (mkVarOcc "ExceptionContext", exceptionContextTyConKey) + + -- Custom type errors + , (mkTcOcc "TypeError", errorMessageTypeErrorFamKey) + , (mkDataOcc "Text", typeErrorTextDataConKey) + , (mkDataOcc ":<>:", typeErrorAppendDataConKey) + , (mkDataOcc ":$$:", typeErrorVAppendDataConKey) + , (mkDataOcc "ShowType", typeErrorShowTypeDataConKey) + -- Base strings Strings , (mkVarOcc "unpackCString#", unpackCStringIdKey) , (mkVarOcc "unpackCStringUtf8#", unpackCStringUtf8IdKey) + -- JS primitives + , (mkVarOcc "unsafeUnpackJSStringUtf8##", unsafeUnpackJSStringUtf8ShShKey) + -- Known-key names that have BuiltinRules in ConstantFold , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) , (mkVarOcc "unpackFoldrCStringUtf8#", unpackCStringFoldrUtf8IdKey) @@ -343,42 +359,22 @@ knownKeyTable basicKnownKeyNames :: [Name] -- See Note [Known-key names] basicKnownKeyNames = [ + -- KindReps for common cases + starKindRepName, + starArrStarKindRepName, + starArrStarArrStarKindRepName, + constraintKindRepName, -- FFI primitive types that are not wired-in. ptrTyConName, funPtrTyConName, constPtrConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, - jsvalTyConName, - - -- Type-level naturals - knownNatClassName, knownSymbolClassName, knownCharClassName, - - -- ExceptionContext - exceptionContextTyConName, - emptyExceptionContextName, - - -- Call Stacks - callStackTyConName, - emptyCallStackName, -- Plugins pluginTyConName , frontendPluginTyConName - -- StaticPtr - , staticPtrTyConName - , staticPtrDataConName, staticPtrInfoDataConName - - -- Custom type errors - , errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - -- Unsafe coercion proofs , unsafeCoercePrimName - - , unsafeUnpackJSStringUtf8ShShName ] @@ -425,33 +421,21 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key -- End of ghc-bignum --------------------------------- + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +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. +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey + -- WithDict withDictClassName :: Name withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey --- Custom type errors -errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - :: Name - -errorMessageTypeErrorFamName = - tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey - -typeErrorTextDataConName = - dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey - -typeErrorAppendDataConName = - dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey - -typeErrorVAppendDataConName = - dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey - -typeErrorShowTypeDataConName = - dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey - -- Unsafe coercion proofs unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey @@ -478,28 +462,6 @@ ptrTyConName, funPtrTyConName :: Name ptrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "Ptr") ptrTyConKey funPtrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey --- Type-level naturals -knownNatClassName :: Name -knownNatClassName = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassKey -knownSymbolClassName :: Name -knownSymbolClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassKey -knownCharClassName :: Name -knownCharClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassKey - --- ExceptionContext -exceptionContextTyConName, emptyExceptionContextName :: Name -exceptionContextTyConName = - tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey -emptyExceptionContextName - = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey - --- Source Locations -callStackTyConName, emptyCallStackName :: Name -callStackTyConName - = tcQual gHC_INTERNAL_STACK_TYPES (fsLit "CallStack") callStackTyConKey -emptyCallStackName - = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey - -- plugins pLUGINS :: Module pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins") @@ -508,31 +470,10 @@ pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey frontendPluginTyConName :: Name frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey -staticPtrInfoTyConName :: Name -staticPtrInfoTyConName = - tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey - -staticPtrInfoDataConName :: Name -staticPtrInfoDataConName = - dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey - -staticPtrTyConName :: Name -staticPtrTyConName = - tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey - -staticPtrDataConName :: Name -staticPtrDataConName = - dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey - constPtrConName :: Name constPtrConName = tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey -jsvalTyConName :: Name -jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey - -unsafeUnpackJSStringUtf8ShShName :: Name -unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey {- ************************************************************************ @@ -871,12 +812,6 @@ specTyConKey = mkPreludeTyConUnique 185 smallArrayPrimTyConKey = mkPreludeTyConUnique 187 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 -staticPtrTyConKey :: KnownKey -staticPtrTyConKey = mkPreludeTyConUnique 189 - -staticPtrInfoTyConKey :: KnownKey -staticPtrInfoTyConKey = mkPreludeTyConUnique 190 - callStackTyConKey :: KnownKey callStackTyConKey = mkPreludeTyConUnique 191 @@ -1344,6 +1279,13 @@ typeCharTypeRepKey = mkPreludeMiscIdUnique 509 typeRepIdKey = mkPreludeMiscIdUnique 510 mkTrFunKey = mkPreludeMiscIdUnique 511 +-- KindReps for common cases +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: KnownKey +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 +constraintKindRepKey = mkPreludeMiscIdUnique 523 + -- Dynamic toDynIdKey :: KnownKey toDynIdKey = mkPreludeMiscIdUnique 530 @@ -1362,18 +1304,12 @@ memptyClassOpKey = mkPreludeMiscIdUnique 555 mappendClassOpKey = mkPreludeMiscIdUnique 556 mconcatClassOpKey = mkPreludeMiscIdUnique 557 -emptyCallStackKey :: KnownKey -emptyCallStackKey = mkPreludeMiscIdUnique 558 - fromStaticPtrClassOpKey :: KnownKey fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 makeStaticKey :: KnownKey makeStaticKey = mkPreludeMiscIdUnique 561 -emptyExceptionContextKey :: KnownKey -emptyExceptionContextKey = mkPreludeMiscIdUnique 562 - -- Unsafe coercion proofs unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: KnownKey unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -204,6 +204,16 @@ fromStaticPtrClassOpOcc, newStablePtrIdOcc :: KnownOcc fromStaticPtrClassOpOcc = mkVarOcc "fromStaticPtr" newStablePtrIdOcc = mkVarOcc "newStablePtr" +staticPtrTyConOcc, staticPtrDataConOcc, staticPtrInfoDataConOcc :: KnownOcc +staticPtrTyConOcc = mkTcOcc "StaticPtr" +staticPtrDataConOcc = mkDataOcc "StaticPtr" +staticPtrInfoDataConOcc = mkDataOcc "StaticPtrInfo" + +knownNatClassOcc, knownSymbolClassOcc, knownCharClassOcc :: KnownOcc +knownNatClassOcc = mkTcOcc "KnownNat" +knownSymbolClassOcc = mkTcOcc "KnownSymbol" +knownCharClassOcc = mkTcOcc "KnownChar" + returnIOIdOcc, bindIOIdOcc, thenIOIdOcc, printIdOcc, ioTyConOcc, ioDataConOcc :: KnownOcc returnIOIdOcc = mkVarOcc "returnIO" @@ -321,15 +331,6 @@ traceIdOcc = mkVarOcc "trace" assertErrorIdOcc :: KnownOcc assertErrorIdOcc = mkVarOcc "assertError" --- KindReps for common cases --- See Note [Grand plan for Typeable] (GPT6) in GHC.Tc.Instance.Typeable. -starKindRepIdOcc, starArrStarKindRepIdOcc, - starArrStarArrStarKindRepIdOcc, constraintKindRepIdOcc :: KnownOcc -starKindRepIdOcc = mkVarOcc "krepStar" -starArrStarKindRepIdOcc = mkVarOcc "krepArrStar" -starArrStarArrStarKindRepIdOcc = mkVarOcc "krepStarArrStarArrStarKind" -constraintKindRepIdOcc = mkVarOcc "krepConstraint" - -- ghci ghciIoClassOcc, ghciStepIoMOcc :: KnownOcc ghciIoClassOcc = mkTcOcc "GHCiSandboxIO" @@ -340,9 +341,14 @@ toAnnotationWrapperIdOcc :: KnownOcc toAnnotationWrapperIdOcc = mkVarOcc "toAnnotationWrapper" -- CallStacks/Source locations -pushCallStackIdOcc, srcLocDataConOcc :: KnownOcc -pushCallStackIdOcc = mkVarOcc "pushCallStack" -srcLocDataConOcc = mkDataOcc "SrcLoc" +emptyCallStackIdOcc, pushCallStackIdOcc, srcLocDataConOcc :: KnownOcc +emptyCallStackIdOcc = mkVarOcc "emptyCallStack" +pushCallStackIdOcc = mkVarOcc "pushCallStack" +srcLocDataConOcc = mkDataOcc "SrcLoc" + +-- ExceptionContext +emptyExceptionContextIdOcc :: KnownOcc +emptyExceptionContextIdOcc = mkVarOcc "emptyExceptionContext" {- ********************************************************************* * * ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -244,7 +244,7 @@ import {-# SOURCE #-} GHC.Builtin.WiredIn.Types , manyDataConTy, oneDataConTy , liftedRepTy, unliftedRepTy, zeroBitRepTy ) -import GHC.Types.Name( Name ) +import GHC.Types.Name( Name, hasKnownKey ) import GHC.Builtin.KnownKeys import GHC.Core.Coercion.Axiom @@ -1226,21 +1226,21 @@ pprUserTypeErrorTy ty = -- Text "Something" Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName + | tc `hasKnownKey` typeErrorTextDataConKey , Just str <- isStrLitTy txt -> ftext str -- ShowType t Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t + | tc `hasKnownKey` typeErrorShowTypeDataConKey -> ppr t -- t1 :<>: t2 Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> + | tc `hasKnownKey` typeErrorAppendDataConKey -> pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 -- t1 :$$: t2 Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> + | tc `hasKnownKey` typeErrorVAppendDataConKey -> pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 -- An unevaluated type function ===================================== compiler/GHC/Driver/Config/Tidy.hs ===================================== @@ -17,7 +17,7 @@ import GHC.Driver.Backend import GHC.Core.Make (getMkStringIds) import GHC.Builtin.KnownKeys -import GHC.Tc.Utils.Env (lookupGlobal, lookupKnownKeyGlobal) +import GHC.Tc.Utils.Env (lookupKnownKeyGlobal) import GHC.Types.TyThing import GHC.Platform.Ways @@ -48,8 +48,8 @@ initStaticPtrOpts hsc_env = do let dflags = hsc_dflags hsc_env mk_string <- getMkStringIds (fmap tyThingId . lookupKnownKeyGlobal hsc_env) - static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName - static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName + static_ptr_info_datacon <- tyThingDataCon <$> lookupKnownKeyGlobal hsc_env staticPtrInfoDataConKey + static_ptr_datacon <- tyThingDataCon <$> lookupKnownKeyGlobal hsc_env staticPtrDataConKey pure $ StaticPtrOpts { opt_platform = targetPlatform dflags ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -14,7 +14,6 @@ module GHC.Stg.BcPrep ( bcPrep ) where import GHC.Prelude -import GHC.Types.Id.Make import GHC.Types.Id import GHC.Core.Type ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -111,7 +111,7 @@ genApp ctx i args -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal, -- if so then we convert the unsafeUnpack to a call to h$decode. | [StgVarArg v] <- args - , idName i == unsafeUnpackJSStringUtf8ShShName + , i `hasKnownKey` unsafeUnpackJSStringUtf8ShShKey -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588 -- Comment by Josh Meredith <josh.meredith@iohk.io> -- `typex_expr` can throw an error for certain bindings so it's important @@ -122,7 +122,7 @@ genApp ctx i args -- Test case T23479 | [StgLitArg (LitString bs)] <- args , Just d <- decodeModifiedUTF8 bs - , idName i == unsafeUnpackJSStringUtf8ShShName + , i `hasKnownKey` unsafeUnpackJSStringUtf8ShShKey , [top] <- concatMap typex_expr (ctxTarget ctx) = return . (,ExprInline) $ top |= toJExpr d ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -629,7 +629,7 @@ tcExpr (HsStatic _ expr) res_ty -- StaticPtr a -> p a ; fromStaticPtr <- newKnownOccMethod StaticOrigin fromStaticPtrClassOpOcc [p_ty] - ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName + ; static_ptr_ty_con <- tcLookupKnownOccTyCon staticPtrTyConOcc ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] static_expr_ty = mkTyConApp static_ptr_ty_con [expr_ty] ; return $ mkHsWrapCo co $ ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -27,12 +27,13 @@ import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Prim import GHC.Builtin.KnownKeys +import GHC.Builtin.KnownOccs import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Builtin.PrimOps.Ids ( primOpId ) import GHC.Types.FieldLabel import GHC.Types.SafeHaskell -import GHC.Types.Name ( Name ) +import GHC.Types.Name ( Name, KnownOcc ) import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id @@ -960,9 +961,9 @@ matchTypeable clas [k,t] -- clas = Typeable -- see Note [No Typeable for polytypes or qualified types] -- Now cases that do work - | k `eqType` naturalTy = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | k `eqType` charTy = doTyLit knownCharClassName t + | k `eqType` naturalTy = doTyLit knownNatClassOcc t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassOcc t + | k `eqType` charTy = doTyLit knownCharClassOcc t | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks @@ -1038,8 +1039,8 @@ mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal -- we generate a sub-goal for the appropriate class. -- See Note [Typeable for Nat and Symbol] -doTyLit :: Name -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupClass kc +doTyLit :: KnownOcc -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupKnownOccClass kc ; let kc_pred = mkClassPred kc_clas [ t ] mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) mk_ev _ = panic "doTyLit" ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -22,6 +22,7 @@ import GHC.Tc.Utils.TcType import GHC.Iface.Env( newGlobalBinder ) import GHC.Builtin.Modules( gHC_TYPES, gHC_PRIM ) +import GHC.Builtin.KnownKeys import GHC.Builtin.KnownOccs import GHC.Builtin.WiredIn.Prim ( primTyCons ) import GHC.Builtin.WiredIn.Types @@ -136,15 +137,6 @@ There are many wrinkles: KindReps once in GHC.Types. These are referred to as "built-in" KindReps below. - * When compiling GHC.Internal.Types, generate some extra bindings for - built-in kindreps (see `todoForExportedKindReps`): - - krepStar = MkTyCon app ... - - * Re-export `krepStar` from GHC.Essentials. - * In `mkTypeableBinds`, use `krepStar` directly rather than using its - long form. Must use lookupKnownOcc to find it. - (GPT7) Even though KindReps aren't inlined, this scheme still has more of an effect on compilation time than I'd like. This is especially true in the case of families of type constructors (e.g. tuples and unboxed @@ -471,12 +463,11 @@ todoForTyCons mod mod_id tycons = do mod_fpr = fingerprintString $ moduleNameString $ moduleName mod pkg_fpr = fingerprintString $ unitString $ moduleUnit mod -todoForExportedKindReps :: [(Kind, KnownOcc)] -> TcM TypeRepTodo +todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo todoForExportedKindReps kinds = do trKindRepTy <- mkTyConTy <$> tcLookupKnownOccTyCon kindRepTyConOcc - names <- mapM (fmap idName . tcLookupKnownOccId . snd) kinds -- ROMES:TODO: ugh... I don't see how this would work. These bindings are defined dynamically here when compiling this module, so how would knownOcc find them? they aren't defined! - let mkId k name = (k, mkExportedVanillaId name trKindRepTy) - return $ ExportedKindRepsTodo $ zipWith mkId (map fst kinds) names + let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) + return $ ExportedKindRepsTodo $ map mkId kinds -- | Generate TyCon bindings for a set of type constructors mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv @@ -671,13 +662,13 @@ liftTc = KindRepM . lift -- | We generate `KindRep`s for a few common kinds, so that they -- can be reused across modules. --- These definitions are generated in `GHC.Internal.Types`. -builtInKindReps :: [(Kind, KnownOcc)] +-- These definitions are generated in `ghc-prim:GHC.Types`. +builtInKindReps :: [(Kind, Name)] builtInKindReps = - [ (star, starKindRepIdOcc) - , (constraintKind, constraintKindRepIdOcc) - , (mkVisFunTyMany star star, starArrStarKindRepIdOcc) - , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepIdOcc) + [ (star, starKindRepName) + , (constraintKind, constraintKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) + , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) ] where star = liftedTypeKind @@ -686,7 +677,7 @@ initialKindRepEnv :: TcRn KindRepEnv initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps where add_kind_rep acc (k,n) = do - id <- tcLookupKnownOccId n + id <- tcLookupId n return $! extendTypeMap acc k (id, Nothing) -- The TypeMap looks through type synonyms ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -40,9 +40,10 @@ import GHC.Types.Unique.Set import GHC.Types.Id import GHC.Builtin +import GHC.Builtin.KnownOccs ( emptyExceptionContextIdOcc ) import GHC.Builtin.KnownKeys( unsatisfiableIdKey , isStringClassKey - , emptyExceptionContextName ) + ) import GHC.Builtin.Modules ( gHC_INTERNAL_TYPEERROR ) import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Ids ( unboxedUnitExpr ) @@ -449,7 +450,7 @@ defaultExceptionContext ct | ClassPred cls tys <- classifyPredType (ctPred ct) , isJust (isExceptionContextPred cls tys) = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct) - ; empty_ec_id <- wrapTcS (TcM.tcLookupId emptyExceptionContextName) + ; empty_ec_id <- wrapTcS (TcM.tcLookupKnownOccId emptyExceptionContextIdOcc) ; let ev = ctEvidence ct ev_tm = EvExpr (evWrapIPE (ctEvPred ev) (Var empty_ec_id)) ; setDictIfWanted ev EvCanonical ev_tm ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -45,8 +45,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.SrcLoc -import GHC.Builtin.KnownOccs( pushCallStackIdOcc, srcLocDataConOcc ) -import GHC.Builtin.KnownKeys( emptyCallStackName ) +import GHC.Builtin.KnownOccs( emptyCallStackIdOcc, pushCallStackIdOcc, srcLocDataConOcc ) import GHC.Utils.Monad ( concatMapM ) import GHC.Utils.Outputable @@ -187,7 +186,7 @@ solveCallStack ev ev_cs evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence evCallStack _ EvCsEmpty - = Var <$> wrapTcS (tcLookupId emptyCallStackName) + = Var <$> wrapTcS (tcLookupKnownOccId emptyCallStackIdOcc) evCallStack pred (EvCsPushCall fs loc tm) = do { df <- getDynFlags ; m <- getModule ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -136,7 +136,7 @@ import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Utils.TcMType as TcM import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified GHC.Tc.Utils.Env as TcM - ( tcGetDefaultTys, tcLookupKnownKeyId, tcLookupTyCon ) + ( tcGetDefaultTys, tcLookupKnownKeyId, tcLookupKnownKeyTyCon ) import GHC.Tc.Zonk.Monad ( ZonkM ) import qualified GHC.Tc.Zonk.TcType as TcM @@ -159,7 +159,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Constraint -import GHC.Builtin.KnownKeys ( callStackTyConName, exceptionContextTyConName ) +import GHC.Builtin.KnownKeys ( callStackTyConKey, exceptionContextTyConKey ) import GHC.Core.Make import GHC.Core.Type @@ -569,8 +569,8 @@ updSolvedDicts :: InstanceWhat -> DictCt -> TcS () updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) | isWanted ev , instanceReturnsDictCon what - = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName - ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName + = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConKey + ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConKey ; let contains_callstack_or_exceptionCtx = mightMentionIP (const True) @@ -593,9 +593,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) -- per Note [Using typesAreApart when calling mightMentionIP]. -- -- See Note [Using isCallStackTy in mightMentionIP]. - is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) - is_tyConTy is_eq tc_name - = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name + is_tyConTy :: (Type -> Bool) -> KnownKey -> TcS (Type -> Bool) + is_tyConTy is_eq tc_key + = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupKnownKeyTyCon tc_key ; case mb_tc of Just tc -> return $ \ ty -> not (typesAreApart ty (mkTyConTy tc)) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1426,7 +1426,7 @@ userTypeError_maybe look_everywhere = go | Just ty' <- coreView ty = go ty' go (TyConApp tc tys) - | tyConName tc == errorMessageTypeErrorFamName + | tc `hasKnownKey` errorMessageTypeErrorFamKey , _kind : msg : _ <- tys -- There may be more than 2 arguments, if the type error is -- used as a type constructor (e.g. at kind `Type -> Type`). ===================================== ghc/GHCi/UI.hs ===================================== @@ -78,9 +78,8 @@ import GHC.Types.SourceError ( SourceError, initSourceErrorContext ) import GHC.Types.Name import GHC.Types.Var ( varType ) import GHC.Iface.Syntax ( showToHeader ) -import GHC.Builtin.KnownKeys( ghciStepIoMName ) -import GHC.Builtin.KnownOccs( ioTyConOcc, stringTyCon_RDR, compose_RDR ) -import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName, greName, globalRdrEnvElts) +import GHC.Builtin.KnownOccs( ghciStepIoMOcc, ioTyConOcc, stringTyCon_RDR, compose_RDR ) +import GHC.Types.Name.Reader as RdrName import GHC.Types.SrcLoc as SrcLoc import qualified GHC.Parser.Lexer as Lexer import GHC.Parser.Header ( toArgs ) @@ -2011,7 +2010,7 @@ defineMacro overwrite s let stringTy :: LHsType GhcPs stringTy = nlHsTyVar NotPromoted stringTyCon_RDR ioM :: LHsType GhcPs -- AZ - ioM = nlHsTyVar NotPromoted (ExactOcc ioTyConOcc) `nlHsAppTy` stringTy + ioM = nlHsTyVar NotPromoted (Exact (ExactOcc ioTyConOcc)) `nlHsAppTy` stringTy body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $ @@ -2081,8 +2080,8 @@ getGhciStepIO = do ghciTyConName <- GHC.getGHCiMonad let stringTy = nlHsTyVar NotPromoted stringTyCon_RDR ghciM = nlHsTyVar NotPromoted (Exact ghciTyConName) `nlHsAppTy` stringTy - ioM = nlHsTyVar NotPromoted (ExactOcc ioTyConOcc) `nlHsAppTy` stringTy - body = nlHsVar (getRdrName ghciStepIoMName) + ioM = nlHsTyVar NotPromoted (Exact (ExactOcc ioTyConOcc)) `nlHsAppTy` stringTy + body = nlHsVar (Exact (ExactOcc ghciStepIoMOcc)) tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $ nlHsFunTy ghciM ioM return $ noLocA $ ExprWithTySig noAnn body tySig ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -126,11 +126,19 @@ module GHC.Essentials -- WithDict , WithDict + -- Type-level naturals/symbols/chars + , KnownNat, KnownSymbol, KnownChar + + -- Custom type errors + , TypeError + , ErrorMessage(..) + -- Unsatisfiable , Unsatisfiable, unsatisfiable -- Static pointers , IsStatic( fromStaticPtr ), makeStatic + , StaticPtr( StaticPtr ), StaticPtrInfo( StaticPtrInfo ) -- Stable pointers , StablePtr, newStablePtr @@ -149,6 +157,9 @@ module GHC.Essentials , CS.unpackAppendCStringUtf8#, CS.cstringLength# , eqString, inline + -- JS primitives + , unsafeUnpackJSStringUtf8## + , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof -- Typeable and type representations @@ -216,16 +227,16 @@ module GHC.Essentials , Body, normalB, guardedB , Guard, normalGE, patGE - -- See Note [Grand plan for Typeable] point (GPT6) - , krepStar, krepArrStar - , krepStarArrStarArrStarKind - , krepConstraint - -- GHCi , GHCiSandboxIO(ghciStepIO) -- Callstacks - , pushCallStack, SrcLoc(..) + , CallStack, emptyCallStack, pushCallStack, SrcLoc(..) + + -- Exception context + , ExceptionContext, emptyExceptionContext + + , toAnnotationWrapper ) where import GHC.Internal.Base hiding( foldr ) @@ -236,6 +247,8 @@ import GHC.Internal.Real import Data.String( IsString ) import GHC.Internal.Ix import GHC.Internal.Magic.Dict( WithDict ) +import GHC.Internal.TypeNats( KnownNat ) +import GHC.Internal.TypeLits( KnownSymbol, KnownChar ) import GHC.Internal.Enum import GHC.Internal.Data.Dynamic( toDyn ) import GHC.Internal.Data.Data @@ -253,7 +266,7 @@ import GHC.Internal.Desugar( (>>>) ) -- See Note [Tricky known-occ cases] import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records import GHC.Internal.CString as CS -import GHC.Internal.TypeError( Unsatisfiable, unsatisfiable ) +import GHC.Internal.TypeError( TypeError, ErrorMessage(..), Unsatisfiable, unsatisfiable ) import GHC.Internal.System.IO( print ) import qualified GHC.Internal.IsList as IL import GHC.Internal.Err( error ) @@ -263,7 +276,7 @@ import GHC.Internal.Word( Word8(W8#), Word16(W16#), Word32(W32#), Word64(W64#) ) import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) -import GHC.Internal.StaticPtr( IsStatic(..) ) +import GHC.Internal.StaticPtr( IsStatic(..), StaticPtr(..), StaticPtrInfo(..) ) import GHC.Internal.StaticPtr.Internal( makeStatic ) import GHC.Internal.Stable( StablePtr, newStablePtr ) @@ -280,7 +293,8 @@ import GHC.Internal.TH.Lib import GHC.Internal.TH.Lift import GHC.Internal.TH.Monad import GHC.Internal.TopHandler -import GHC.Internal.Classes.IP (IP) import GHC.Internal.GHCi import GHC.Internal.Desugar (toAnnotationWrapper) import GHC.Internal.Stack.Types +import GHC.Internal.Exception.Context +import GHC.Internal.JS.Prim (unsafeUnpackJSStringUtf8##) ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Exception.Context ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} module GHC.Internal.Exception.Context where ===================================== libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs ===================================== @@ -6,6 +6,8 @@ {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + module GHC.Internal.JS.Prim ( JSVal(..), JSVal# , JSException(..) , WouldBlockException(..) ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs ===================================== @@ -9,6 +9,7 @@ -- we hide this module from haddock to enforce GHC.Internal.Stack as the main -- access point. +{-# OPTIONS_GHC -fdefines-known-key-names #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Stack.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Types.hs ===================================== @@ -8,7 +8,6 @@ -- NegativeLiterals: see Note [Fixity of (->)] {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} -{-# OPTIONS_GHC -frebindable-known-names #-} -- built-in type reps (e.g. krepStar) are defined in this module. ----------------------------------------------------------------------------- -- | View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8f3006f84841af96028cea4ee4cc94... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8f3006f84841af96028cea4ee4cc94... You're receiving this email because of your account on gitlab.haskell.org.