GitLab

Cheng Shao pushed to branch wip/fix-hpc-bytecode-modname at Glasgow Haskell Compiler / GHC

Commits:

704164be

by Cheng Shao at 2026-05-25T13:59:10+00:00

ghci: fix module name string lifetime in hs_hpc_module invocation

This patch makes hpcAddModule pass a properly malloced module name
string to hs_hpc_module, instead of using useAsCString which causes
use-after-free of module name string. Fixes #27297.

Co-authored-by: Codex <codex@openai.com>

4 changed files:

+ libraries/ghc-boot/GHC/Data/ShortByteString.hs
libraries/ghc-boot/ghc-boot.cabal.in
libraries/ghci/GHCi/Coverage.hs
libraries/ghci/GHCi/Run.hs

Changes:

libraries/ghc-boot/GHC/Data/ShortByteString.hs

 +module GHC.Data.ShortByteString
 +  ( newCStringFromSBS
 +  ) where
++
 +import Prelude
++
 +import qualified Data.ByteString.Short as SBS
 +import Foreign
 +import Foreign.C
++
 +newCStringFromSBS :: SBS.ShortByteString -> IO CString
 +newCStringFromSBS sbs =
 +  SBS.useAsCStringLen sbs $ \(src, len) -> do
 +    dst <- mallocBytes (len + 1)
 +    copyBytes dst src len
 +    pokeByteOff dst len (0 :: Word8)
 +    pure dst

libraries/ghc-boot/ghc-boot.cabal.in

@@ -51,6 +51,7 @@ Library
      exposed-modules:
              GHC.BaseDir
 +            GHC.Data.ShortByteString
              GHC.Data.ShortText
              GHC.Data.SizedSeq
              GHC.Data.SmallArray

libraries/ghci/GHCi/Coverage.hs

@@ -9,9 +9,9 @@ import Prelude -- See note [Why do we import Prelude here?]
  import Control.Exception
  import Data.ByteString.Short (ShortByteString)
 -import qualified Data.ByteString.Short as SBS
  import Data.Word
  import Foreign
 +import GHC.Data.ShortByteString
  import GHC.Foreign (CString)
  import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString)
  import GHCi.ObjLink (lookupSymbol)
@@ -31,17 +31,19 @@ hpcAddModule ::
    -- ^ Name of the ticks array found in the c-stub.
    IO ()
  hpcAddModule modlName ticks hash tickboxes = do
 -  SBS.useAsCString modlName $ \modlNameLiteral -> do
 -    -- we need to find the reference to the ticks array.
 -    lookupSymbol tickboxes >>= \ case
 -      Nothing -> do
 -        -- the symbol is not found, this is a bug!
 -        throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes
 -      Just tickBoxRef -> do
 -        -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once.
 -        hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef)
 -        -- calling 'hpc_startup' multiple times is safe, it will only be initialised once.
 -        hpc_startup
 +  -- we need to find the reference to the ticks array.
 +  lookupSymbol tickboxes >>= \ case
 +    Nothing -> do
 +      -- the symbol is not found, this is a bug!
 +      throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes
 +    Just tickBoxRef -> do
 +      -- hs_hpc_module stores the module name pointer in the RTS hash table
 +      -- until exitHpc, so pass a malloced C string.
 +      modlNameLiteral <- newCStringFromSBS modlName
 +      -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once.
 +      hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef)
 +      -- calling 'hpc_startup' multiple times is safe, it will only be initialised once.
 +      hpc_startup
  foreign import ccall unsafe "hs_hpc_module"
      hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO ()

libraries/ghci/GHCi/Run.hs

@@ -37,6 +37,9 @@ import Control.Monad
  import Data.ByteString (ByteString)
  import qualified Data.ByteString.Short.Internal as BS
  import qualified Data.ByteString.Unsafe as B
 +#if defined(PROFILING)
 +import GHC.Data.ShortByteString
 +#endif
  import GHC.Exts
  import qualified GHC.Exts.Heap as Heap
  import GHC.Stack
@@ -447,13 +450,6 @@ mkCostCentres mod ccs = do
      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