Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d054b467 by Cheng Shao at 2026-03-11T15:05:59-04:00 compiler: implement string interning logic for BCONPtrFS This patch adds a `FastStringEnv`-based cache of `MallocStrings` requests to `Interp`, so that when we load bytecode with many breakpoints that share the same module names & unit ids, we reuse the allocated remote pointers instead of issuing duplicte `MallocStrings` requests and bloating the C heap. Closes #26995. - - - - - 4 changed files: - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs Changes: ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -42,6 +42,7 @@ import qualified GHC.Types.Id as Id import GHC.Types.Unique.DFM -- Standard libraries +import Control.Concurrent import Data.Array.Unboxed import Foreign.Ptr import GHC.Exts @@ -87,9 +88,12 @@ lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of BCONPtrStr bs -> do RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] pure $ fromIntegral p - BCONPtrFS fs -> do - RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs] - pure $ fromIntegral p + BCONPtrFS fs -> modifyMVar (interpStringCache interp) $ \fs_env -> + case lookupFsEnv fs_env fs of + Just (RemotePtr p) -> pure (fs_env, fromIntegral p) + Nothing -> do + rp@(RemotePtr p) <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs] + pure (extendFsEnv fs_env fs rp, fromIntegral p) BCONPtrFFIInfo (FFIInfo {..}) -> do RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet pure $ fromIntegral p ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2845,7 +2845,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do case interp of -- always generate JS code for the JS interpreter (no bytecode!) - Interp (ExternalInterp (ExtJS i)) _ _ -> + Interp { interpInstance = ExternalInterp (ExtJS i) } -> jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id _ -> do ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -9,6 +9,7 @@ where import GHC.Prelude +import GHC.Data.FastString.Env import GHC.Driver.DynFlags import GHC.Platform import GHC.Platform.Ways @@ -71,6 +72,8 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do lookup_cache <- liftIO $ mkInterpSymbolCache + fs_cache <- liftIO $ newMVar emptyFsEnv + -- see Note [Target code interpreter] if #if !defined(wasm32_HOST_ARCH) @@ -100,7 +103,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts) , wasmInterpUnitState = ue_homeUnitState unit_env } - pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache fs_cache #endif -- JavaScript interpreter @@ -119,7 +122,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do , jsInterpFinderOpts = interpFinderOpts opts , jsInterpFinderCache = finder_cache } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache fs_cache)) -- external interpreter | interpExternal opts @@ -146,7 +149,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do } s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)) -- Internal interpreter | otherwise @@ -154,7 +157,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader lookup_cache)) + return (Just (Interp InternalInterp loader lookup_cache fs_cache)) #else return Nothing #endif ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -47,6 +47,7 @@ import GHC.Linker.Types import GHCi.RemoteTypes import GHCi.Message ( Pipe ) +import GHC.Data.FastString.Env import GHC.Platform #if defined(HAVE_INTERNAL_INTERPRETER) import GHC.Platform.Ways @@ -75,6 +76,9 @@ data Interp = Interp , interpSymbolCache :: !InterpSymbolCache -- ^ LookupSymbol cache + + , interpStringCache :: !(MVar (FastStringEnv (RemotePtr ()))) + -- ^ MallocStrings cache } data InterpInstance View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d054b4676298ea2189cd48fcf175676b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d054b4676298ea2189cd48fcf175676b... You're receiving this email because of your account on gitlab.haskell.org.