[Git][ghc/ghc][master] perf: Key the interpreter symbol cache by Name rather than FastString
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Feb 6 22:16:37 UTC 2025
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f71c2835 by Matthew Pickering at 2025-02-06T17:16:02-05:00
perf: Key the interpreter symbol cache by Name rather than FastString
Profiles showed that about 0.2s was being spend constructing the keys
before looking up values in the old symbol cache.
The performance of this codepath is critical as it translates directly
to a delay when a user evaluates a function like `main` in the
interpreter.
Therefore we implement a solution which keys the cache(s) by `Name`
rather than the symbol directly, so the cache can be consulted before
the symbol is constructed.
Fixes #25731
- - - - -
8 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- + compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -420,7 +420,6 @@ import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.Breakpoint
import GHC.Types.PkgQual
-import GHC.Types.Unique.FM
import GHC.Unit
import GHC.Unit.Env as UnitEnv
@@ -705,7 +704,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags dflags = do
hsc_env <- getSession
logger <- getLogger
- lookup_cache <- liftIO $ newMVar emptyUFM
+ lookup_cache <- liftIO $ mkInterpSymbolCache
-- Interpreter
interp <- if
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -12,7 +13,6 @@ module GHC.ByteCode.Linker
( linkBCO
, lookupStaticPtr
, lookupIE
- , nameToCLabel
, linkFail
)
where
@@ -26,7 +26,6 @@ import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
-import GHC.Builtin.Names
import GHC.Unit.Types
@@ -43,8 +42,6 @@ import GHC.Types.Name.Env
import qualified GHC.Types.Id as Id
import GHC.Types.Unique.DFM
-import Language.Haskell.Syntax.Module.Name
-
-- Standard libraries
import Data.Array.Unboxed
import Foreign.Ptr
@@ -92,30 +89,30 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr interp addr_of_label_string = do
- m <- lookupSymbol interp addr_of_label_string
+ m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
- (unpackFS addr_of_label_string)
+ (ppr addr_of_label_string)
lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE interp pkgs_loaded ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
- let sym_to_find1 = nameToCLabel con_nm "con_info"
- m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"
+ let sym_to_find1 = IConInfoSymbol con_nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find1
case m of
Just addr -> return addr
Nothing
-> do -- perhaps a nullary constructor?
- let sym_to_find2 = nameToCLabel con_nm "static_info"
- n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"
+ let sym_to_find2 = IStaticInfoSymbol con_nm
+ n <- lookupHsSymbol interp pkgs_loaded sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
- (unpackFS sym_to_find1 ++ " or " ++
- unpackFS sym_to_find2)
+ (ppr sym_to_find1 <> " or " <>
+ ppr sym_to_find2)
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
@@ -123,21 +120,21 @@ lookupAddr interp pkgs_loaded ae addr_nm = do
case lookupNameEnv ae addr_nm of
Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
Nothing -> do -- try looking up in the object files.
- let sym_to_find = nameToCLabel addr_nm "bytes"
+ let sym_to_find = IBytesSymbol addr_nm
-- see Note [Bytes label] in GHC.Cmm.CLabel
- m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp interp pkgs_loaded primop = do
let sym_to_find = primopToCLabel primop "closure"
- m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"
+ m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))
case m of
Just p -> return (toRemotePtr p)
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)
resolvePtr
:: Interp
@@ -157,11 +154,11 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
| otherwise
-> assertPpr (isExternalName nm) (ppr nm) $
do
- let sym_to_find = nameToCLabel nm "closure"
- m <- lookupHsSymbol interp pkgs_loaded nm "closure"
+ let sym_to_find = IClosureSymbol nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)
BCOPtrPrimOp op
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
@@ -176,11 +173,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-- loaded units.
--
-- See Note [Looking up symbols in the relevant objects].
-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
- massertPpr (isExternalName nm) (ppr nm)
- let sym_to_find = nameToCLabel nm sym_suffix
- pkg_id = moduleUnitId $ nameModule nm
+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded sym_to_find = do
+ massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)
+ let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)
loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
go (dll:dlls) = do
@@ -194,12 +190,12 @@ lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
go loaded_dlls
-linkFail :: String -> String -> IO a
+linkFail :: String -> SDoc -> IO a
linkFail who what
= throwGhcExceptionIO (ProgramError $
unlines [ "",who
, "During interactive linking, GHCi couldn't find the following symbol:"
- , ' ' : ' ' : what
+ , ' ' : ' ' : showSDocUnsafe what
, "This may be due to you not asking GHCi to load extra object files,"
, "archives or DLLs needed by your current session. Restart GHCi, specifying"
, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
@@ -210,28 +206,8 @@ linkFail who what
])
-nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastStringByteString label
- where
- encodeZ = fastZStringToByteString . zEncodeFS
- (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
- -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
- -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
- mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
- mod -> mod
- packagePart = encodeZ (unitFS pkgKey)
- modulePart = encodeZ (moduleNameFS modName)
- occPart = encodeZ $ occNameMangledFS (nameOccName n)
-
- label = mconcat $
- [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
- ++
- [modulePart
- , "_"
- , occPart
- , "_"
- , fromString suffix
- ]
+
+
-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2901,7 +2901,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots
-- look up "id_sym" closure and create a StablePtr (HValue) from it
- href <- lookupClosure interp (unpackFS id_sym) >>= \case
+ href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case
Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
Just r -> pure r
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -217,12 +217,12 @@ loadName interp hsc_env name = do
case lookupNameEnv (closure_env (linker_env pls)) name of
Just (_,aa) -> return (pls,(aa, links, pkgs))
Nothing -> assertPpr (isExternalName name) (ppr name) $
- do let sym_to_find = nameToCLabel name "closure"
- m <- lookupClosure interp (unpackFS sym_to_find)
+ do let sym_to_find = IClosureSymbol name
+ m <- lookupClosure interp sym_to_find
r <- case m of
Just hvref -> mkFinalizedHValue interp hvref
Nothing -> linkFail "GHC.Linker.Loader.loadName"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
return (pls,(r, links, pkgs))
loadDependencies
@@ -909,7 +909,7 @@ dynLoadObjs interp hsc_env pls at LoaderState{..} objs = do
m <- loadDLL interp soFile
case m of
Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
- Left err -> linkFail msg err
+ Left err -> linkFail msg (text err)
where
msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
-- | Interacting with the iserv interpreter, whether it is running on an
-- external process or in the current process.
@@ -83,7 +84,6 @@ import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Utils.Panic
@@ -116,6 +116,12 @@ import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
+import GHC.Builtin.Names
+import GHC.Types.Name
+
+-- Standard libraries
+import GHC.Exts
+
{- Note [Remote GHCi]
~~~~~~~~~~~~~~~~~~
When the flag -fexternal-interpreter is given to GHC, interpreted code
@@ -457,38 +463,65 @@ handleSeqHValueStatus interp unit_env eval_status =
initObjLinker :: Interp -> IO ()
initObjLinker interp = interpCmd interp InitLinker
-lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
-lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
+ sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
-lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
+interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString
+interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is ->
+ let
+ n = interpSymbolName is
+ suffix = interpSymbolSuffix is
+
+ encodeZ = fastZStringToByteString . zEncodeFS
+ (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
+ -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
+ -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
+ mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
+ mod -> mod
+ packagePart = encodeZ (unitFS pkgKey)
+ modulePart = encodeZ (moduleNameFS modName)
+ occPart = encodeZ $ occNameMangledFS (nameOccName n)
+
+ label = mconcat $
+ [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
+ ++
+ [modulePart
+ , "_"
+ , occPart
+ , "_"
+ , fromString suffix
+ ]
+ in mkFastStringByteString label
+
+lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure str)
+ interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
@@ -496,7 +529,7 @@ lookupClosure interp str =
-- a miss we run the action which determines the symbol's address and populate
-- the cache with the answer.
withSymbolCache :: Interp
- -> FastString
+ -> InterpSymbol s
-- ^ The symbol we are looking up in the cache
-> IO (Maybe (Ptr ()))
-- ^ An action which determines the address of the symbol we
@@ -513,21 +546,19 @@ withSymbolCache interp str determine_addr = do
-- The analysis in #23415 further showed this cache should also benefit the
-- internal interpreter's loading times, and needn't be used by the external
-- interpreter only.
- cache <- readMVar (interpLookupSymbolCache interp)
- case lookupUFM cache str of
- Just p -> return (Just p)
+ cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp)
+ case cached_val of
+ Just {} -> return cached_val
Nothing -> do
-
maddr <- determine_addr
case maddr of
Nothing -> return Nothing
Just p -> do
- let upd_cache cache' = addToUFM cache' str p
- modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)
- return (Just p)
+ updateInterpSymbolCache str (interpSymbolCache interp) p
+ return maddr
purgeLookupSymbolCache :: Interp -> IO ()
-purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))
+purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Types used by the runtime interpreter
module GHC.Runtime.Interpreter.Types
@@ -10,6 +12,20 @@ module GHC.Runtime.Interpreter.Types
, ExtInterpInstance (..)
, ExtInterpState (..)
, InterpStatus(..)
+ -- * InterpSymbolCache
+ , InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+
+
-- * IServ
, IServ
, IServConfig(..)
@@ -30,9 +46,6 @@ import GHC.Linker.Types
import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
-import GHC.Types.Unique.FM
-import GHC.Data.FastString ( FastString )
-import Foreign
import GHC.Platform
import GHC.Utils.TmpFs
@@ -42,6 +55,7 @@ import GHC.Unit.State
import GHC.Unit.Types
import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Types
+import GHC.Runtime.Interpreter.Types.SymbolCache
import Control.Concurrent
import System.Process ( ProcessHandle, CreateProcess )
@@ -56,7 +70,7 @@ data Interp = Interp
, interpLoader :: !Loader
-- ^ Interpreter loader
- , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+ , interpSymbolCache :: !InterpSymbolCache
-- ^ LookupSymbol cache
}
=====================================
compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
=====================================
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | The SymbolCache is used to cache lookups for specific symbols when using
+-- the interpreter.
+module GHC.Runtime.Interpreter.Types.SymbolCache (
+ InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+ ) where
+
+import GHC.Prelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Name
+import GHC.Data.FastString
+import Foreign
+
+import Control.Concurrent
+import GHC.Utils.Outputable
+import GHC.TypeLits
+
+
+-- The symbols records the suffix which each cache deals with.
+newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }
+
+-- Each cache is keyed by Name, there is one cache for each type of symbol we will
+-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult
+-- a complicated `FastString` each time.
+data InterpSymbolCache = InterpSymbolCache {
+ interpClosureCache :: MVar (SymbolCache "closure")
+ , interpConInfoCache :: MVar (SymbolCache "con_info")
+ , interpStaticInfoCache :: MVar (SymbolCache "static_info")
+ , interpBytesCache :: MVar (SymbolCache "bytes")
+ , interpFaststringCache :: MVar (UniqFM FastString (Ptr ()))
+ }
+
+data SuffixOrInterpreted = Suffix Symbol | Interpreted
+
+data InterpSymbol (s :: SuffixOrInterpreted) where
+ IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")
+ IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")
+ IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")
+ IBytesSymbol :: Name -> InterpSymbol (Suffix "bytes")
+ IFaststringSymbol :: FastString -> InterpSymbol Interpreted
+
+instance Outputable (InterpSymbol s) where
+ ppr s = eliminateInterpSymbol s
+ (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)
+ (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))
+
+eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> r)
+ -> r
+eliminateInterpSymbol s k1 k2 =
+ case s of
+ IFaststringSymbol {} -> k1 s
+ IBytesSymbol {} -> k2 s
+ IStaticInfoSymbol {} -> k2 s
+ IConInfoSymbol {} -> k2 s
+ IClosureSymbol {} -> k2 s
+
+
+interpSymbolName :: InterpSymbol (Suffix s) -> Name
+interpSymbolName (IClosureSymbol n) = n
+interpSymbolName (IConInfoSymbol n) = n
+interpSymbolName (IStaticInfoSymbol n) = n
+interpSymbolName (IBytesSymbol n) = n
+
+interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString
+interpretedInterpSymbol (IFaststringSymbol s) = s
+
+interpSymbolSuffix :: InterpSymbol (Suffix s) -> String
+interpSymbolSuffix (IClosureSymbol {}) = "closure"
+interpSymbolSuffix (IConInfoSymbol {}) = "con_info"
+interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"
+interpSymbolSuffix (IBytesSymbol {}) = "bytes"
+
+emptySymbolCache :: SymbolCache s
+emptySymbolCache = SymbolCache emptyUFM
+
+lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())
+lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)
+
+insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s
+insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)
+
+lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))
+lookupInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)
+ (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)
+
+
+updateInterpSymbolCache :: InterpSymbol s
+ -> InterpSymbolCache -> Ptr () -> IO ()
+updateInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))
+ (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))
+
+withInterpSymbolCache ::
+ (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)
+ -> InterpSymbol s
+ -> InterpSymbolCache
+ -> r
+withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =
+ case key of
+ IClosureSymbol {} -> k2 key interpClosureCache
+ IConInfoSymbol {} -> k2 key interpConInfoCache
+ IStaticInfoSymbol {} -> k2 key interpStaticInfoCache
+ IBytesSymbol {} -> k2 key interpBytesCache
+ IFaststringSymbol {} -> k1 key interpFaststringCache
+
+-- | Clear all symbol caches.
+purgeInterpSymbolCache :: InterpSymbolCache -> IO ()
+purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do
+ modifyMVar_ a (\_ -> do
+ modifyMVar_ b (\_ -> do
+ modifyMVar_ c (\_ -> do
+ modifyMVar_ d (\_ -> do
+ modifyMVar_ e (\_ -> pure emptyUFM)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+
+mkInterpSymbolCache :: IO InterpSymbolCache
+mkInterpSymbolCache = do
+ InterpSymbolCache <$> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptyUFM
=====================================
compiler/ghc.cabal.in
=====================================
@@ -699,6 +699,7 @@ Library
GHC.Runtime.Interpreter.JS
GHC.Runtime.Interpreter.Process
GHC.Runtime.Interpreter.Types
+ GHC.Runtime.Interpreter.Types.SymbolCache
GHC.Runtime.Interpreter.Wasm
GHC.Runtime.Loader
GHC.Runtime.Utils
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f71c2835bfacac879b294bbcd475d7acfac4adfb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f71c2835bfacac879b294bbcd475d7acfac4adfb
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250206/5c9af18c/attachment-0001.html>
More information about the ghc-commits
mailing list