Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8dd6f453 by Cheng Shao at 2026-04-08T04:38:11-04:00 ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages This patch refactors ghci to use `ShortByteString` for `LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the first part of #27147. Co-authored-by: Codex <codex@openai.com> - - - - - 371ef200 by Cheng Shao at 2026-04-08T04:38:11-04:00 ghci: use ShortByteString for MkCostCentres message This patch refactors ghci to use `ShortByteString` for `MkCostCentres` messages as a first part of #27147. This also considerably lowers the memory overhead of breakpoints when cost center profiling is enabled. ------------------------- Metric Decrease: interpreter_steplocal ------------------------- Co-authored-by: Codex <codex@openai.com> - - - - - 12 changed files: - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/driver/linkwhole/Main.hs - testsuite/tests/ghci/should_run/T18064.script - testsuite/tests/rts/KeepCafsMain.hs - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import Control.DeepSeq +import qualified Data.ByteString.Short as SBS import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] getBreakDecls = getBreakXXX modBreaks_decls --- | Get the decls for this breakpoint -getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String)) +-- | Get the cost centre info for this breakpoint +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString) getBreakCCS = getBreakXXX modBreaks_ccs -- | Internal utility to access a ModBreaks field at a particular breakpoint index ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -405,7 +405,7 @@ loadExternalPlugins ps = do symbol | null unit = ztmp | otherwise = zEncodeString unit ++ "_" ++ ztmp - plugin <- lookupSymbol symbol >>= \case + plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case Nothing -> pprPanic "loadExternalPlugins" (vcat [ text "Symbol not found" , text " Library path: " <> text path ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints import GHC.Prelude import Data.Array +import qualified Data.ByteString.Short as SBS import GHC.HsToCore.Ticks (Tick (..)) import GHC.Data.SizedSeq @@ -31,6 +32,7 @@ import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) import GHC.Utils.Binary +import GHC.Utils.Encoding (utf8EncodeShortByteString) import GHC.Utils.Outputable import Data.List (intersperse) import Data.Coerce @@ -59,7 +61,7 @@ data ModBreaks , modBreaks_decls :: !(Array BreakTickIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. -- See Note [Field modBreaks_decls] - , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString)) -- ^ Array pointing to cost centre info for each breakpoint; -- actual 'CostCentre' allocation is done at link-time. , modBreaks_module :: !Module @@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries | interpreterProfiled = listArray (0, count - 1) - [ ( concat $ intersperse "." $ tick_path t, - renderWithContext defaultSDocContext $ ppr $ tick_loc t + [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t, + utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t ) | t <- entries ] ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss ccs <- {- one ccs ptr per tick index -} mkCostCentres interp - (moduleNameString $ moduleName modBreaks_module) + (moduleNameFS $ moduleName modBreaks_module) (elems modBreaks_ccs) return $ M.fromList $ zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -107,6 +107,7 @@ import Control.Monad.IO.Class import Control.Monad.Catch as MC (mask) import Data.Binary import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS import Foreign hiding (void) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) @@ -352,9 +353,15 @@ evalStringToIOString interp fhv str = mallocData :: Interp -> ByteString -> IO (RemotePtr ()) mallocData interp bs = interpCmd interp (MallocData bs) -mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres interp mod ccs = - interpCmd interp (MkCostCentres mod ccs) +mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre] +mkCostCentres interp mod ccs = do + rp <- modifyMVar (interpStringCache interp) $ \fs_env -> + case lookupFsEnv fs_env mod of + Just rp -> pure (fs_env, rp) + Nothing -> do + rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod] + pure (extendFsEnv fs_env mod rp, rp) + interpCmd interp $ MkCostCentres rp ccs -- | Create a set of BCOs that may be mutually recursive. createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] @@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId evalBreakpointToId eval_break = let mkUnitId u = fsToUnit $ mkFastStringShortByteString u - toModule u n = mkModule (mkUnitId u) (mkModuleName n) + toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n)) in InternalBreakpointId { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) @@ -465,27 +472,27 @@ 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 (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (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 (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) 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 (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (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 @@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is - lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) lookupClosure interp str = - interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str))) + interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str))) -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -- which maps symbols to the address where they are loaded. ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -86,9 +86,9 @@ data Message a where -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () - LookupSymbol :: String -> Message (Maybe (RemotePtr ())) - LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) - LookupClosure :: String -> Message (Maybe HValueRef) + LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef) LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL]) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? @@ -162,8 +162,8 @@ data Message a where -- | Create a set of CostCentres with the same module name MkCostCentres - :: String -- module, RemotePtr so it can be shared - -> [(String,String)] -- (name, SrcSpan) + :: !(RemotePtr ()) -- ModuleName + -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan) -> Message [RemotePtr CostCentre] -- | Show a 'CostCentreStack' as a @[String]@ @@ -430,7 +430,7 @@ data EvalStatus_ a b instance Binary a => Binary (EvalStatus_ a b) data EvalBreakpoint = EvalBreakpoint - { eb_info_mod :: String -- ^ Breakpoint info module + { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id , eb_info_index :: Int -- ^ Breakpoint info index } ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -31,6 +31,8 @@ import GHCi.RemoteTypes import GHCi.Message (LoadedDLL) import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) +import qualified Data.ByteString.Short as BS +import Data.Char (ord) import Data.Foldable import Foreign.C import Foreign.Marshal.Alloc ( alloca, free ) @@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f purgeObj :: String -> IO () purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f -lookupSymbol :: String -> IO (Maybe (Ptr a)) -lookupSymbol sym = do - r <- js_lookupSymbol $ toJSString sym +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) +lookupSymbol sym@(BS.SBS ba#) = do + r <- js_lookupSymbolPtr ba# (BS.length sym) evaluate $ if r == nullPtr then Nothing else Just r -foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)" - js_lookupSymbol :: JSString -> IO (Ptr a) +foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)" + js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL _ _ = pure Nothing resolveObjs :: IO Bool @@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO () initObjLinker RetainCAFs = c_initLinker_ 1 initObjLinker _ = c_initLinker_ 0 -lookupSymbol :: String -> IO (Maybe (Ptr a)) +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr then return Nothing else return (Just addr) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL dll str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbolInNativeObj dll c_str if addr == nullPtr then return Nothing else return (Just addr) -prefixUnderscore :: String -> String +prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString prefixUnderscore - | cLeadingUnderscore = ('_':) + | cLeadingUnderscore = BS.cons (fromIntegral (ord '_')) | otherwise = id -- | loadDLL loads a dynamic library using the OS's native linker @@ -298,7 +300,7 @@ isWindowsHost = False #endif -lookupClosure :: String -> IO (Maybe HValueRef) +lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupClosure str = do m <- lookupSymbol str case m of ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -34,7 +34,7 @@ import Control.DeepSeq import Control.Exception import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B import GHC.Exts import qualified GHC.Exts.Heap as Heap @@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #) -lookupJSClosure' :: String -> IO Int -lookupJSClosure' str = withCString str $ \cstr -> IO (\s -> +lookupJSClosure' :: BS.ShortByteString -> IO Int +lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s -> case lookupJSClosure# cstr s of (# s', r #) -> (# s', I# r #)) -lookupJSClosure :: String -> IO (Maybe HValueRef) +lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupJSClosure str = lookupJSClosure' str >>= \case 0 -> pure Nothing r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r)))) @@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act if is_exception then pure Nothing else do - info_mod <- peekCString (Ptr info_mod#) + info_mod <- BS.packCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs @@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do pokeElemOff (ptr :: Ptr CChar) len 0 return (castRemotePtr (toRemotePtr ptr)) -mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre] #if defined(PROFILING) mkCostCentres mod ccs = do - c_module <- newCString mod + let c_module = fromRemotePtr $ castRemotePtr mod mapM (mk_one c_module) ccs where mk_one c_module (decl_path,srcspan) = do - c_name <- newCString decl_path - c_srcspan <- newCString srcspan + c_name <- newCStringFromSBS decl_path + c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan + newCStringFromSBS sbs = do + let len = BS.length sbs + buf <- mallocBytes $ len + 1 + BS.copyToPtr sbs 0 buf (fromIntegral len) + pokeByteOff buf len (0 :: Word8) + pure buf + foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else ===================================== testsuite/tests/driver/linkwhole/Main.hs ===================================== @@ -1,9 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Exception import Control.Monad +import Data.ByteString.Short (ShortByteString) import Foreign @@ -15,7 +17,7 @@ import GHCi.ObjLink rotateSO :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a))) - -> String + -> ShortByteString -> (Maybe FilePath, FilePath) -> IO a rotateSO dynamicCall symName (old, newDLL) = do ===================================== testsuite/tests/ghci/should_run/T18064.script ===================================== @@ -1,2 +1,3 @@ +:set -XOverloadedStrings import GHCi.ObjLink lookupClosure "blah" ===================================== testsuite/tests/rts/KeepCafsMain.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main (main) where import Foreign ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1334,6 +1334,13 @@ class DyLD { } return 0; } + + lookupSymbolPtr(symPtr, symLen) { + const sym = new TextDecoder("utf-8", { fatal: true }).decode( + new Uint8Array(this.#memory.buffer, symPtr, symLen) + ); + return this.lookupSymbol(sym); + } } // The main entry point of dyld that may be run on node/browser, and View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fef352168d5975499b97f9e46fff0cb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fef352168d5975499b97f9e46fff0cb... You're receiving this email because of your account on gitlab.haskell.org.