Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 403ea05c by Rodrigo Mesquita at 2026-04-30T15:17:04+01:00 otherwiseIdName, assertName, dollarName - - - - - eb7432a3 by Rodrigo Mesquita at 2026-04-30T15:17:04+01:00 traceName - - - - - 46776041 by Rodrigo Mesquita at 2026-04-30T15:17:04+01:00 assertError - - - - - 1b34499d by Rodrigo Mesquita at 2026-04-30T15:17:05+01:00 trGhcPrimModule - - - - - f7bfb829 by Rodrigo Mesquita at 2026-04-30T15:17:05+01:00 StablePtr tc - - - - - bcc565ab by Rodrigo Mesquita at 2026-04-30T15:17:05+01:00 WIP: KREPS - - - - - 1795a105 by Rodrigo Mesquita at 2026-04-30T15:17:05+01:00 Revert "WIP: KREPS" TODO GET BACK This reverts commit 695374c1e0418b7c78b43cdeb965d8005fe37b77. - - - - - 29aaf086 by Rodrigo Mesquita at 2026-04-30T16:56:38+01:00 unpackCString, unpackCStringUtf8; DROP MonadThings Issue: how to do getMkStringIds in `Driver.Config.Tidy`? - - - - - 23 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Core/Make.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Plugins.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/Tc/Gen/Head.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/Utils/Env.hs - compiler/GHC/Types/TyThing.hs - libraries/base/src/GHC/Essentials.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -240,6 +240,9 @@ knownKeyTable -- Static pointers , (mkVarOcc "makeStatic", makeStaticKey) + -- Stable pointers + , (mkTcOcc "StablePtr", stablePtrTyConKey) + -- WithDict , (mkTcOcc "WithDict", withDictClassKey) @@ -247,6 +250,9 @@ knownKeyTable , (mkTcOcc "Unsatisfiable", unsatisfiableClassKey) , (mkVarOcc "unsatisfiable", unsatisfiableIdKey) + -- Base strings Strings + , (mkVarOcc "unpackCString#", unpackCStringIdKey) + , (mkVarOcc "unpackCStringUtf8#", unpackCStringUtf8IdKey) -- Known-key names that have BuiltinRules in ConstantFold , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) @@ -340,27 +346,19 @@ basicKnownKeyNames ioTyConName, ioDataConName, -- KindReps for common cases - trGhcPrimModuleName, starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, constraintKindRepName, - -- Strings and lists - unpackCStringName, unpackCStringUtf8Name, - -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, + ptrTyConName, funPtrTyConName, constPtrConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, jsvalTyConName, -- Others - otherwiseIdName, - assertName, - assertErrorName, traceName, printName, - dollarName, -- Type-level naturals knownNatClassName, knownSymbolClassName, knownCharClassName, @@ -431,11 +429,6 @@ wildCardName = mkSystemVarName wildCardKey (fsLit "wild") specTyConName :: Name specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey --- Base strings Strings -unpackCStringName, unpackCStringUtf8Name :: Name -unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey - -- Class MonadFail failMName :: Name failMName = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail") failMClassOpKey @@ -453,14 +446,6 @@ pureAClassOpKey = mkPreludeMiscIdUnique 752 thenAClassOpKey = mkPreludeMiscIdUnique 753 alternativeClassKey = mkPreludeMiscIdUnique 754 --- Random GHC.Internal.Base functions -otherwiseIdName, - assertName, - dollarName :: Name -dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey -otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey -assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey - bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key @@ -474,11 +459,10 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key -- Class Typeable, and functions for constructing `Typeable` dictionaries -trGhcPrimModuleName, starKindRepName, starArrStarKindRepName, +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 starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey @@ -515,14 +499,6 @@ typeErrorShowTypeDataConName = unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey --- Error module -assertErrorName :: Name -assertErrorName = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey - --- GHC.Internal.Debug.Trace -traceName :: Name -traceName = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey - genericClassKeys :: [KnownKey] genericClassKeys = [genClassKey, gen1ClassKey] @@ -559,10 +535,6 @@ ptrTyConName, funPtrTyConName :: Name ptrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "Ptr") ptrTyConKey funPtrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey --- Foreign objects and weak pointers -stablePtrTyConName :: Name -stablePtrTyConName = tcQual gHC_INTERNAL_STABLE (fsLit "StablePtr") stablePtrTyConKey - -- Annotation type checking toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey @@ -1124,12 +1096,10 @@ srcLocDataConKey :: KnownKey srcLocDataConKey = mkPreludeDataConUnique 37 trTyConDataConKey, trModuleDataConKey, - trNameSDataConKey, - trGhcPrimModuleKey :: KnownKey + trNameSDataConKey :: KnownKey trTyConDataConKey = mkPreludeDataConUnique 41 trModuleDataConKey = mkPreludeDataConUnique 43 trNameSDataConKey = mkPreludeDataConUnique 45 -trGhcPrimModuleKey = mkPreludeDataConUnique 47 typeErrorTextDataConKey, typeErrorAppendDataConKey, @@ -1316,10 +1286,9 @@ rootMainKey, runMainKey :: KnownKey rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: KnownKey +thenIOIdKey, lazyIdKey, oneShotKey, runRWKey :: KnownKey thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 -assertErrorIdKey = mkPreludeMiscIdUnique 105 oneShotKey = mkPreludeMiscIdUnique 106 runRWKey = mkPreludeMiscIdUnique 107 ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -312,6 +312,12 @@ metaSelDataConOcc = mkDataOcc "MetaSel" runMainIOOcc :: KnownOcc runMainIOOcc = mkVarOcc "runMainIO" +traceIdOcc :: KnownOcc +traceIdOcc = mkVarOcc "trace" + +assertErrorIdOcc :: KnownOcc +assertErrorIdOcc = mkVarOcc "assertError" + {- ********************************************************************* * * Known-occ RdrNames ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -15,7 +15,7 @@ module GHC.Core.Make ( mkIntExpr, mkIntExprInt, mkUncheckedIntExpr, mkIntegerExpr, mkNaturalExpr, mkFloatExpr, mkDoubleExpr, - mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + mkCharExpr, mkStringExprWith, mkStringExprFSWith, MkStringIds (..), getMkStringIds, -- * Floats @@ -53,7 +53,6 @@ import GHC.Platform import GHC.Types.Id import GHC.Types.Var ( visArgConstraintLike ) -import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Cpr import GHC.Types.Basic( TypeOrConstraint(..) ) @@ -291,27 +290,18 @@ mkDoubleExpr r = mkCoreConApps doubleDataCon [mkDoubleLit r] mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] --- | Create a 'CoreExpr' which will evaluate to the given @String@ -mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String -mkStringExpr str = mkStringExprFS (mkFastString str) - --- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ -mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String -mkStringExprFS = mkStringExprFSLookup lookupId - -mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr -mkStringExprFSLookup lookupM str = do - mk <- getMkStringIds lookupM - pure (mkStringExprFSWith mk str) - -getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds -getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name - data MkStringIds = MkStringIds { unpackCStringId :: !Id , unpackCStringUtf8Id :: !Id } +getMkStringIds :: Applicative m => (KnownKey -> m Id) -> m MkStringIds +getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringIdKey <*> lookupM unpackCStringUtf8IdKey + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExprWith :: MkStringIds -> String -> CoreExpr -- Result :: String +mkStringExprWith mks = mkStringExprFSWith mks . mkFastString + mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr mkStringExprFSWith ids str | nullFS str ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -178,7 +178,7 @@ dsCFExportDynamic id co0 cconv = do -- depending on Unique. See #13807 and Note [Unique Determinism]. cback <- newSysLocalDs scaled_arg_ty newStablePtrId <- dsLookupKnownOccId newStablePtrIdOcc - stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + stable_ptr_tycon <- dsLookupKnownKeyTyCon stablePtrTyConKey let stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] export_ty = mkVisFunTyMany stable_ptr_ty arg_ty ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -278,7 +278,7 @@ dsJsFExportDynamic id co0 cconv = do -- depending on Unique. See #13807 and Note [Unique Determinism]. cback <- newSysLocalDs scaled_arg_ty newStablePtrId <- dsLookupKnownOccId newStablePtrIdOcc - stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + stable_ptr_tycon <- dsLookupKnownKeyTyCon stablePtrTyConKey let stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] export_ty = mkVisFunTyMany stable_ptr_ty arg_ty ===================================== compiler/GHC/HsToCore/Foreign/Wasm.hs ===================================== @@ -135,7 +135,7 @@ dsWasmJSDynamicExport :: CCallStaticTargetUnit -> DsM ([Binding], CHeader, CStub, [Id]) dsWasmJSDynamicExport sync fn_id co unitId = do - sp_tycon <- dsLookupTyCon stablePtrTyConName + sp_tycon <- dsLookupKnownKeyTyCon stablePtrTyConKey let ty = coercionLKind co (tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty @@ -338,7 +338,8 @@ dsWasmJSStaticImport fn_id co js_src' unitId sync = do importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src ) Async -> do - err_msg <- mkStringExpr $ js_src + mk_str <- getMkStringIds dsLookupKnownKeyId + let err_msg = mkStringExprWith mk_str js_src io_tycon <- dsLookupKnownKeyTyCon ioTyConKey jsval_ty <- mkTyConTy ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -117,7 +117,7 @@ dsLit l = do HsFloatPrim _ fl -> return (mkFloatLit (rationalFromFractionalLit fl)) HsDoublePrim _ fl -> return (mkDoubleLit (rationalFromFractionalLit fl)) HsChar _ c -> return (mkCharExpr c) - HsString _ str -> mkStringExprFS str + HsString _ str -> (`mkStringExprFSWith` str) <$> getMkStringIds dsLookupKnownKeyId HsNatural _ i -> return (mkNaturalExpr platform (il_value i)) HsDouble _ fl -> return (mkDoubleExpr (fromRational (rationalFromFractionalLit fl))) HsInt _ i -> return (mkIntExpr platform (il_value i)) @@ -633,7 +633,8 @@ matchLiterals (var :| vars) ty sub_groups = do { -- We now have to convert back to FastString. Perhaps there -- should be separate LitBytes and LitString constructors? let s' = mkFastStringByteString s - ; lit <- mkStringExprFS s' + ; mks <- getMkStringIds dsLookupKnownKeyId + ; let lit = mkStringExprFSWith mks s' ; let pred = mkApps (Var eq_str) [Var var, lit] ; return (mkGuardedMatchResult pred mr) } wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -87,6 +85,7 @@ import GHC.Iface.Load import GHC.Tc.Utils.Monad +import GHC.Builtin.KnownOccs (traceIdOcc) import GHC.Builtin.KnownKeys import GHC.Data.FastString @@ -567,10 +566,6 @@ failDs = failM mkNamePprCtxDs :: DsM NamePprCtx mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv -instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where - lookupThing = dsLookupGlobal - - {- ********************************************************************* * * Looking things up in the monad @@ -730,8 +725,8 @@ pprRuntimeTrace :: String -- ^ header -> CoreExpr -- ^ expression -> DsM CoreExpr pprRuntimeTrace str doc expr = do - traceId <- dsLookupGlobalId traceName - unpackCStringId <- dsLookupGlobalId unpackCStringName + traceId <- dsLookupKnownOccId traceIdOcc + unpackCStringId <- dsLookupKnownKeyId unpackCStringIdKey dflags <- getDynFlags let message :: CoreExpr message = App (Var unpackCStringId) $ ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -79,7 +79,6 @@ import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.InlinePragma import GHC.Types.SourceText -import GHC.Types.TyThing import GHC.Types.Name hiding( varName, tcName ) import GHC.Types.Name.Env @@ -105,6 +104,8 @@ data MetaWrappers = MetaWrappers { , metaTy :: Type -> Type -- Information about the wrappers which be printed to be inspected , _debugWrappers :: (HsWrapper, HsWrapper, Type) + -- MkStringIds to make exprs with mStringExprFSWith + , mkStringsMeta :: MkStringIds } -- | Construct the functions which will apply the relevant part of the @@ -130,6 +131,7 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty) + mk_strs <- getMkStringIds dsLookupKnownKeyId let m_ty = Type m_var -- Construct the contents of MetaWrappers @@ -140,7 +142,7 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do debug = (quoteWrapper, monadWrapper, m_var) dsHsWrapper quoteWrapper $ \q_f -> do { dsHsWrapper monadWrapper $ \m_f -> do { - return (MetaWrappers q_f m_f tyWrapper debug) } } + return (MetaWrappers q_f m_f tyWrapper debug mk_strs) } } -- Turn A into m A wrapName :: KnownOcc -> MetaM Type @@ -736,7 +738,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s cis' <- conv_cimportspec cis - MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis')) + MkC str <- lift $ coreStringLit (mkFastString (static ++ chStr ++ cis')) dec <- krep2 forImpDOcc [cc', s', str, name', typ'] return (locA loc, dec) where @@ -802,7 +804,7 @@ repRuleD (L loc (HsRule { rd_name = n , rd_rhs = rhs })) = fmap (locA loc, ) <$> repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' -> - do { n' <- coreStringLit $ unLoc n + do { n' <- lift $ coreStringLit $ unLoc n ; act' <- repPhases act ; lhs' <- repLE lhs ; rhs' <- repLE rhs @@ -1166,7 +1168,7 @@ rep_sccFun nm Nothing loc = do rep_sccFun nm (Just (L _ str)) loc = do nm1 <- lookupLOcc nm - str1 <- coreStringLit (sl_fs str) + str1 <- lift $ coreStringLit (sl_fs str) scc <- repPragSCCFunNamed nm1 str1 return [(loc, scc)] @@ -1517,7 +1519,7 @@ repTyLit (HsNatural _ i) = do platform <- getPlatform rep2 numTyLitName [mkIntegerExpr platform (il_value i)] repTyLit (HsString _ s) = do - s' <- mkStringExprFS s + s' <- (`mkStringExprFSWith` s) <$> asks mkStringsMeta rep2 strTyLitName [s'] repTyLit (HsChar _ c) = do c' <- return (mkCharExpr c) @@ -1997,7 +1999,7 @@ rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs))) ; return (locA loc, ipb) } rep_implicit_param_name :: HsIPName -> MetaM (Core String) -rep_implicit_param_name (HsIPName name) = coreStringLit name +rep_implicit_param_name (HsIPName name) = lift $ coreStringLit name rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -- Assumes: all the binders of the binding are already in the meta-env @@ -2397,12 +2399,12 @@ wrapGenSyms binds body@(MkC b) go _ [] = return body go var_ty ((name,id) : binds) = do { MkC body' <- go var_ty binds - ; lit_str <- occNameLit (occName name) + ; lit_str <- lift $ occNameLit (occName name) ; gensym_app <- repGensym lit_str ; repBindM var_ty elt_ty gensym_app (MkC (Lam id body')) } -occNameLit :: MonadThings m => OccName -> m (Core String) +occNameLit :: OccName -> DsM (Core String) occNameLit name = coreStringLit (occNameFS name) @@ -2614,7 +2616,7 @@ repDoBlock doName maybeModName (MkC ss) = do coreModNameM :: MetaM (Core (Maybe TH.ModName)) coreModNameM = case maybeModName of Just m -> do - MkC s <- coreStringLit (moduleNameFS m) + MkC s <- lift $ coreStringLit (moduleNameFS m) mName <- rep2_nw mkModNameName [s] coreJust modNameTyConOcc mName _ -> coreNothing modNameTyConOcc @@ -3166,8 +3168,8 @@ repOverLiteralVal lit = do repQualLit :: HsQualLit GhcRn -> MetaM (Core (M TH.Exp)) repQualLit QualLit{ql_mod = modName, ql_val = lit} = do - modNameStr <- coreStringLit (moduleNameFS modName) - funNameStr <- coreStringLit (occNameFS funOcc) + modNameStr <- lift $ coreStringLit (moduleNameFS modName) + funNameStr <- lift $ coreStringLit (occNameFS funOcc) funExp <- repVar =<< repNameQ modNameStr funNameStr litCore <- lift . dsLit =<< mkHsLit litExp <- repLit =<< krep2_nw litFunName [litCore] @@ -3183,16 +3185,16 @@ repQualLit QualLit{ql_mod = modName, ql_val = lit} = do repRdrName :: RdrName -> MetaM (Core TH.Name) repRdrName rdr_name = do case rdr_name of - Unqual occ -> repNameS =<< occNameLit occ + Unqual occ -> repNameS =<< lift (occNameLit occ) Qual mn occ -> do let name_mod = moduleNameFS mn - mod <- coreStringLit name_mod - occ <- occNameLit occ + mod <- lift $ coreStringLit name_mod + occ <- lift $ occNameLit occ repNameQ mod occ Orig m n -> lift $ globalVarExternal m n Exact (ExactName n) -> lift $ globalVar n - Exact (ExactOcc occ) -> repNameS =<< occNameLit occ + Exact (ExactOcc occ) -> repNameS =<< lift (occNameLit occ) -- This is pretty sketchy, but `repRdrName` is only -- used for holes anyway so it probably never happens @@ -3221,19 +3223,19 @@ repUnboundVar (MkC name) = krep2 unboundVarEOcc [name] repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) repOverLabel fs = do - MkC s <- coreStringLit fs + MkC s <- lift $ coreStringLit fs krep2 labelEOcc [s] repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp)) repGetField (MkC exp) fs = do - MkC s <- coreStringLit fs + MkC s <- lift $ coreStringLit fs krep2 getFieldEOcc [exp,s] repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) repProjection fs = do ne_tycon <- lift $ dsLookupKnownOccTyCon nonEmptyTyConOcc MkC xs <- coreListNonEmpty ne_tycon stringTy <$> - mapM coreStringLit fs + mapM (lift . coreStringLit) fs krep2 projectionEOcc [xs] ------------ Lists ------------------- @@ -3292,8 +3294,8 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) -coreStringLit :: MonadThings m => FastString -> m (Core String) -coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) } +coreStringLit :: FastString -> DsM (Core String) +coreStringLit s = do { mks <- getMkStringIds dsLookupKnownKeyId; return (MkC (mkStringExprFSWith mks s)) } ------------------- Maybe ------------------ ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -902,7 +902,8 @@ dsHandleMonadicFailure ctx pat res_ty match m_fail_op = -- that's the non-ApplicativeDo code path mkErrorAppDs pAT_ERROR_ID res_ty (matchDoContextErrString ctx) Just fail_op -> do - fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat) + mk_str <- getMkStringIds dsLookupKnownKeyId + let fail_msg = mkStringExprWith mk_str (mk_fail_msg dflags ctx pat) dsSyntaxExpr fail_op [fail_msg] body fail_expr ===================================== compiler/GHC/Plugins.hs ===================================== @@ -74,7 +74,6 @@ where import GHC.Driver.Plugins -- Variable naming -import GHC.Types.TyThing import GHC.Types.PkgQual import GHC.Types.SourceError import GHC.Types.Name.Reader @@ -145,7 +144,6 @@ import GHC.Iface.Env ( lookupNameCache ) import GHC.Prelude import GHC.Utils.Monad ( MonadIO, mapMaybeM ) import GHC.ThToHs ( thRdrNameGuesses ) -import GHC.Tc.Utils.Env ( lookupGlobal ) import GHC.Types.Name.Cache ( NameCache ) import GHC.Tc.Errors.Hole.FitTypes @@ -158,12 +156,6 @@ import GHC.Hs ( HsParsedModule ) import qualified GHC.Boot.TH.Syntax as TH -{- This instance is defined outside GHC.Core.Opt.Monad so that - GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -} -instance MonadThings CoreM where - lookupThing name = do { hsc_env <- getHscEnv - ; liftIO $ lookupGlobal hsc_env name } - {- ************************************************************************ * * ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Stg.Syntax import GHC.Platform import GHC.Platform.Profile -import GHC.Builtin.KnownKeys (unpackCStringName, unpackCStringUtf8Name) +import GHC.Builtin.KnownKeys (unpackCStringIdKey, unpackCStringUtf8IdKey) import GHC.StgToCmm.Config import GHC.StgToCmm.Expr @@ -183,9 +183,9 @@ isUnpackCStringClosure body = case stripStgTicksTopE (not . tickishIsCode) body _ -> Nothing where is_string_unpack_op f - | idName f == unpackCStringName = Just mkRtsUnpackCStringLabel - | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label - | otherwise = Nothing + | f `hasKnownKey` unpackCStringIdKey = Just mkRtsUnpackCStringLabel + | f `hasKnownKey` unpackCStringUtf8IdKey = Just mkRtsUnpackCStringUtf8Label + | otherwise = Nothing ------------------------------------------------------------------------ -- Non-top-level bindings ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -48,6 +48,7 @@ import GHC.StgToJS.Types import GHC.StgToJS.Utils import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) +import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre @@ -163,7 +164,7 @@ genApp ctx i args -- + Utf8 version below | [StgLitArg (LitString bs)] <- args , Just d <- decodeModifiedUTF8 bs - , idName i == unpackCStringName + , i `hasKnownKey` unpackCStringIdKey , [top] <- concatMap typex_expr (ctxTarget ctx) = return ( top |= app "h$toHsStringA" [toJExpr d] @@ -171,7 +172,7 @@ genApp ctx i args ) | [StgLitArg (LitString bs)] <- args , Just d <- decodeModifiedUTF8 bs - , idName i == unpackCStringUtf8Name + , i `hasKnownKey` unpackCStringUtf8IdKey , [top] <- concatMap typex_expr (ctxTarget ctx) = return ( top |= app "h$toHsString" [toJExpr d] ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -56,6 +56,7 @@ import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Set +import GHC.Types.Name import GHC.Types.Id import GHC.Types.Unique.FM import GHC.Types.RepType @@ -614,7 +615,7 @@ genCase ctx bnd e at alts l | StgLit (LitString bs) <- e , [GenStgAlt DEFAULT _ rhs] <- alts , StgApp i args <- rhs - , idName i == unpackCStringName + , i `hasKnownKey` unpackCStringIdKey , [StgVarArg b'] <- args , bnd == b' , Just d <- decodeModifiedUTF8 bs @@ -626,7 +627,7 @@ genCase ctx bnd e at alts l | StgLit (LitString bs) <- e , [GenStgAlt DEFAULT _ rhs] <- alts , StgApp i args <- rhs - , idName i == unpackCStringUtf8Name + , i `hasKnownKey` unpackCStringUtf8IdKey , [StgVarArg b'] <- args , bnd == b' , Just d <- decodeModifiedUTF8 bs ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -63,6 +63,7 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.Error +import GHC.Builtin.KnownOccs import GHC.Builtin.KnownKeys import GHC.Driver.DynFlags @@ -657,7 +658,8 @@ tcInferId lname@(L loc (WithUserRdr rdr id_name)) do { dflags <- getDynFlags ; if gopt Opt_IgnoreAsserts dflags then tc_infer_id lname - else tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) } + else do { assertErrorName <- idName <$> tcLookupKnownOccId assertErrorIdOcc + ; tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) } } | otherwise = tc_infer_id lname ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Core.Predicate import GHC.Core.Coercion import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) +import GHC.Core.Make ( getMkStringIds, mkCharExpr, mkNaturalExpr, mkStringExprFSWith, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class @@ -378,7 +378,8 @@ matchKnownSymbol :: DynFlags -> Class -> [Type] -> TcM ClsInstResult matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol | Just s <- isStrLitTy ty = do - et <- mkStringExprFS s + mk_str <- getMkStringIds tcLookupKnownKeyId + let et = mkStringExprFSWith mk_str s makeLitDict clas ty et matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys -- See Note [Fabricating Evidence for Literals in Backpack] for why ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -30,7 +30,6 @@ import GHC.Builtin.WiredIn.Types , 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(..) ) @@ -804,7 +803,7 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut new_kind_rep k@(TyConApp tc tys) | Just rep_name <- tyConRepName_maybe tc - = do rep_id <- liftTc $ lookupId rep_name + = do rep_id <- liftTc $ tcLookupId rep_name tys' <- mapM (getKindRep stuff in_scope) tys return $ nlHsDataCon kindRepTyConAppDataCon `nlHsApp` nlHsVar rep_id ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -47,7 +47,6 @@ import GHC.Builtin.Modules ( gHC_INTERNAL_TYPEERROR ) import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Ids ( unboxedUnitExpr ) -import GHC.Types.TyThing ( MonadThings(lookupId) ) import GHC.Types.Unique import GHC.Types.Var import GHC.Types.Var.Env @@ -72,6 +71,7 @@ import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE import GHC.Data.Maybe ( isJust, mapMaybe, catMaybes ) import Data.Monoid ( First(..) ) +import qualified GHC.Tc.Utils.Env as TcM {- Note [Top-level Defaulting Plan] @@ -449,7 +449,7 @@ defaultExceptionContext ct | ClassPred cls tys <- classifyPredType (ctPred ct) , isJust (isExceptionContextPred cls tys) = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct) - ; empty_ec_id <- lookupId emptyExceptionContextName + ; empty_ec_id <- wrapTcS (TcM.tcLookupId emptyExceptionContextName) ; 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 ===================================== @@ -22,6 +22,7 @@ import GHC.Tc.Solver.FunDeps( tryDictFunDeps ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Solver.Types +import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify( uType, mightEqualLater ) @@ -36,7 +37,6 @@ import GHC.Core.InstEnv( DFunInstType ) import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.Unify ( ruleMatchTyKiX ) -import GHC.Types.TyThing( lookupDataCon, lookupId ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Var @@ -186,25 +186,26 @@ solveCallStack ev ev_cs evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence evCallStack _ EvCsEmpty - = Var <$> lookupId emptyCallStackName + = Var <$> wrapTcS (tcLookupId emptyCallStackName) evCallStack pred (EvCsPushCall fs loc tm) = do { df <- getDynFlags ; m <- getModule - ; srcLocDataCon <- lookupDataCon srcLocDataConName + ; srcLocDataCon <- wrapTcS (tcLookupDataCon srcLocDataConName) + ; mk_str <- getTcMkStringsIds ; let platform = targetPlatform df - mkSrcLoc l = mkCoreConWrapApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitFS $ moduleUnit m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt platform (srcSpanStartLine l) - , return $ mkIntExprInt platform (srcSpanStartCol l) - , return $ mkIntExprInt platform (srcSpanEndLine l) - , return $ mkIntExprInt platform (srcSpanEndCol l) - ] - - ; push_cs_id <- lookupId pushCallStackName - ; name_expr <- mkStringExprFS fs - ; loc_expr <- mkSrcLoc loc + mkSrcLoc l = mkCoreConWrapApps srcLocDataCon + [ mkStringExprFSWith mk_str (unitFS $ moduleUnit m) + , mkStringExprFSWith mk_str (moduleNameFS $ moduleName m) + , mkStringExprFSWith mk_str (srcSpanFile l) + , mkIntExprInt platform (srcSpanStartLine l) + , mkIntExprInt platform (srcSpanStartCol l) + , mkIntExprInt platform (srcSpanEndLine l) + , mkIntExprInt platform (srcSpanEndCol l) + ] + + ; push_cs_id <- wrapTcS (tcLookupId pushCallStackName) + ; let name_expr = mkStringExprFSWith mk_str fs + ; let loc_expr = mkSrcLoc loc -- At this point tm :: IP sym CallStack -- but we need the actual CallStack to pass to pushCS, -- so we use evUwrapIP to strip the dictionary wrapper ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -57,7 +57,7 @@ module GHC.Tc.Solver.Monad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getLclEnv, setSrcSpan, - getTcEvBindsVar, getTcLevel, + getTcEvBindsVar, getTcMkStringsIds, getTcLevel, getTcEvBindsMap, setTcEvBindsMap, getTcEvBindsState, combineTcEvBinds, tcLookupKnownKeyId, @@ -161,6 +161,7 @@ import GHC.Tc.Types.Constraint import GHC.Builtin.KnownKeys ( callStackTyConName, exceptionContextTyConName ) +import GHC.Core.Make import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep import GHC.Core.TyCo.Tidy @@ -177,7 +178,6 @@ import GHC.Rename.Env import qualified GHC.Rename.Env as TcM import GHC.Types.Name -import GHC.Types.TyThing import GHC.Types.Name.Reader import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Var @@ -1008,7 +1008,9 @@ data TcSEnv -- See Note [TcSMode] tcs_mode :: TcSMode, - tcs_worklist :: TcRef WorkList + tcs_worklist :: TcRef WorkList, + + tcs_mk_strs :: MkStringIds } --------------- @@ -1043,9 +1045,6 @@ instance MonadUnique TcS where instance HasModule TcS where getModule = wrapTcS getModule -instance MonadThings TcS where - lookupThing n = wrapTcS (lookupThing n) - -- Basic functionality -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ wrapTcS :: TcM a -> TcS a @@ -1190,12 +1189,14 @@ runTcSWithEvBinds' mode ev_binds_var thing_inside ; wl_var <- TcM.newTcRef emptyWorkList ; unif_lvl_var <- TcM.newTcRef infiniteTcLevel + ; mk_strs <- getMkStringIds TcM.tcLookupKnownKeyId ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_what = WU_Coarse unif_lvl_var , tcs_count = step_count , tcs_inerts = inert_var , tcs_mode = mode - , tcs_worklist = wl_var } + , tcs_worklist = wl_var + , tcs_mk_strs = mk_strs } -- Run the computation ; res <- unTcS thing_inside env @@ -1477,6 +1478,9 @@ updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) getTcEvBindsVar :: TcS EvBindsVar getTcEvBindsVar = TcS (return . tcs_ev_binds) +getTcMkStringsIds :: TcS MkStringIds +getTcMkStringsIds = TcS (return . tcs_mk_strs) + getTcLevel :: TcS TcLevel getTcLevel = wrapTcS TcM.getTcLevel ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -213,6 +213,8 @@ importDecl_maybe hsc_env name | otherwise = initIfaceLoad hsc_env (importDecl name) +-------------------------------------------------------------------------------- + addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv addTypecheckedBinds tcg_env binds | isHsBootOrSig (tcg_src tcg_env) = tcg_env @@ -394,9 +396,6 @@ tcGetInstEnvs = do { eps <- getEps , ie_local = tcg_inst_env env , ie_visible = tcVisibleOrphanMods env }) } -instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where - lookupThing = tcLookupGlobal - -- Illegal term-level use of type things failIllegalTyCon :: WhatLooking -> WithUserRdr Name -> TcM a failIllegalTyVar :: WithUserRdr Name -> TcM a ===================================== compiler/GHC/Types/TyThing.hs ===================================== @@ -1,7 +1,6 @@ -- | A global typecheckable-thing, essentially anything that has a name. module GHC.Types.TyThing ( TyThing (..) - , MonadThings (..) , mkATyCon , mkAnId , pprShortTyThing @@ -47,10 +46,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import Control.Monad ( liftM ) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class - import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intersect ) @@ -396,22 +391,3 @@ tyThingId (AnId id) = id tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc tyThingId other = pprPanic "tyThingId" (ppr other) --- | Class that abstracts out the common ability of the monads in GHC --- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides --- a number of related convenience functions for accessing particular --- kinds of 'TyThing' -class Monad m => MonadThings m where - lookupThing :: Name -> m TyThing - - lookupId :: Name -> m Id - lookupId = liftM tyThingId . lookupThing - - lookupDataCon :: Name -> m DataCon - lookupDataCon = liftM tyThingDataCon . lookupThing - - lookupTyCon :: Name -> m TyCon - lookupTyCon = liftM tyThingTyCon . lookupThing - --- Instance used in GHC.HsToCore.Quote -instance MonadThings m => MonadThings (ReaderT s m) where - lookupThing = lift . lookupThing ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -90,6 +90,7 @@ module GHC.Essentials -- Error , error + , assertError -- Numbers , Num, Integral, Real, Floating, Fractional, RealFloat, RealFrac @@ -129,7 +130,7 @@ module GHC.Essentials , IsStatic( fromStaticPtr ), makeStatic -- Stable pointers - , newStablePtr + , StablePtr, newStablePtr -- Dynamic , toDyn @@ -137,6 +138,9 @@ module GHC.Essentials -- Run Top Handler (Note [Dealing with main]) , runMainIO + -- Base strings + , CS.unpackCString# , CS.unpackCStringUtf8# + -- Names that have BuiltinRules , CS.unpackFoldrCString#, CS.unpackFoldrCStringUtf8#, CS.unpackAppendCString# , CS.unpackAppendCStringUtf8#, CS.cstringLength# @@ -239,6 +243,7 @@ import GHC.Internal.TypeError( Unsatisfiable, unsatisfiable ) import GHC.Internal.System.IO( print ) import qualified GHC.Internal.IsList as IL import GHC.Internal.Err( error ) +import GHC.Internal.IO.Exception( assertError ) import GHC.Internal.Int( Int8(I8#), Int16(I16#), Int32(I32#), Int64(I64#) ) import GHC.Internal.Word( Word8(W8#), Word16(W16#), Word32(W32#), Word64(W64#) ) @@ -247,7 +252,7 @@ import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) import GHC.Internal.StaticPtr( IsStatic(..) ) import GHC.Internal.StaticPtr.Internal( makeStatic ) -import GHC.Internal.Stable( newStablePtr ) +import GHC.Internal.Stable( StablePtr, newStablePtr ) import GHC.Internal.Data.Typeable( gcast1, gcast2 ) import GHC.Internal.Data.Typeable.Internal as TR import GHC.Internal.Generics hiding( Fixity(..), prec ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3056af09a86f88f5f054594fcfd8b0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3056af09a86f88f5f054594fcfd8b0... You're receiving this email because of your account on gitlab.haskell.org.