Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 467794d8 by fendor at 2026-04-02T10:58:54+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. Evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. Closes #27036 - - - - - 29 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/include/rts/Bytecodes.h - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Float (castFloatToWord32, castDoubleToWord64) import qualified Data.List as List ( any ) import GHC.Exts +import qualified GHC.Data.Strict as Strict -- ----------------------------------------------------------------------------- @@ -111,8 +112,9 @@ assembleBCOs -> [(Name, ByteString)] -> Maybe InternalModBreaks -> [SptEntry] + -> Strict.Maybe ByteCodeHpcInfo -> IO CompiledByteCode -assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do +assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries use_hpc = do -- TODO: the profile should be bundled with the interpreter: the rts ways are -- fixed for an interpreter let itbls = mkITbls profile tycons @@ -123,6 +125,7 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do , bc_strs = top_strs , bc_breaks = modbreaks , bc_spt_entries = spt_entries + , bc_hpc_info = use_hpc } -- Note [Allocating string literals] @@ -856,6 +859,12 @@ assembleI platform i = case i of emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr , SmallOp ix_hi, SmallOp ix_lo, Op np ] + HPC_TICK lbl ix -> do + p <- lit1 (BCONPtrLbl lbl) + let ix_hi = fromIntegral (ix `shiftR` 16) + ix_lo = fromIntegral (ix .&. 0xffff) + emit_ bci_HPC_TICK [Op p, SmallOp ix_hi, SmallOp ix_lo] + #if MIN_VERSION_rts(1,0,3) BCO_NAME name -> do np <- lit1 (BCONPtrStr name) emit_ bci_BCO_NAME [Op np] ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -15,6 +15,7 @@ import GHC.ByteCode.Types import GHC.Cmm.Type (Width) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable +import GHC.Data.FastString ( FastString ) import GHC.Types.Name import GHC.Types.Literal import GHC.Types.Unique @@ -257,6 +258,7 @@ data BCInstr -- Breakpoints | BRK_FUN !InternalBreakpointId + | HPC_TICK !FastString !Word32 #if MIN_VERSION_rts(1,0,3) -- | A "meta"-instruction for recording the name of a BCO for debugging purposes. @@ -452,6 +454,7 @@ instance Outputable BCInstr where = text "BRK_FUN" <+> text "<breakarray>" <+> ppr info_mod <+> ppr infox <+> text "<cc>" + ppr (HPC_TICK lbl ix) = text "HPC_TICK" <+> ppr lbl <+> ppr ix #if MIN_VERSION_rts(1,0,3) ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm) #endif @@ -578,6 +581,7 @@ bciStackUse OP_INDEX_ADDR{} = 0 bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 +bciStackUse HPC_TICK{} = 0 -- These insns actually reduce stack use, but we need the high-tide level, -- so can't use this info. Not that it matters much. ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -25,6 +25,9 @@ module GHC.ByteCode.Types -- * Mod Breaks , ModBreaks (..), BreakpointId(..), BreakTickIndex + -- * Hpc Info + , ByteCodeHpcInfo(..) + -- * Internal Mod Breaks , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks -- ** Internal breakpoint identifier @@ -35,6 +38,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Data.FlatBag +import qualified GHC.Data.Strict as Strict import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Binary @@ -79,6 +83,25 @@ data CompiledByteCode = CompiledByteCode -- ^ Static pointer table entries which should be loaded along with the -- BCOs. See Note [Grand plan for static forms] in -- "GHC.Iface.Tidy.StaticPtrTable". + + , bc_hpc_info :: !(Strict.Maybe ByteCodeHpcInfo) + -- ^ 'ByteCodeHpcInfo' that should be added to the run-time system when this 'CompiledByteCode' + -- object is loaded. + -- + -- It is safe to load the same 'ByteCodeHpcInfo' multiple times. + } + +-- | ByteCode specific HPC information. +-- +data ByteCodeHpcInfo = ByteCodeHpcInfo + { bchi_module_name :: !String + -- ^ Name of the module. + , bchi_tickbox_name :: !String + -- ^ Name of the tick box that has been added via 'CStub'. + , bchi_tick_count :: {-# UNPACK #-} !Int + -- ^ Number of ticks. + , bchi_hash :: {-# UNPACK #-} !Int + -- ^ mix-file hash. } -- | A libffi ffi_cif function prototype. ===================================== compiler/GHC/Driver/Backend.hs ===================================== @@ -712,8 +712,7 @@ backendSupportsHpc (Named NCG) = True backendSupportsHpc (Named LLVM) = True backendSupportsHpc (Named ViaC) = True backendSupportsHpc (Named JavaScript) = False --- TODO: @terrorjack thinks that the bytecode backend should support HPC now since (!13493) -backendSupportsHpc (Named Bytecode) = False +backendSupportsHpc (Named Bytecode) = True backendSupportsHpc (Named NoBackend) = True -- | This flag says whether the back end supports foreign ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -343,7 +343,6 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" - -- It is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -134,6 +134,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) +import GHC.Driver.Ppr (showSDoc) import GHC.Runtime.Context import GHC.Runtime.Interpreter @@ -151,6 +152,7 @@ import GHC.Hs.Dump import GHC.Hs.Stats ( ppSourceStats ) import GHC.HsToCore +import GHC.HsToCore.Coverage ( hpcTickBoxes, hpcModuleName ) import GHC.StgToByteCode ( byteCodeGen ) import GHC.StgToJS ( stgToJS ) @@ -207,6 +209,8 @@ import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..)) import GHC.StgToCmm.CgUtils (CgStream) +import qualified GHC.ByteCode.Serialize as ByteCode + import GHC.Cmm import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline @@ -237,6 +241,7 @@ import GHC.Types.Var.Set import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.CostCentre +import GHC.Types.HpcInfo (HpcInfo (..)) import GHC.Types.IPE import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -260,6 +265,7 @@ import GHC.Utils.Touch import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.OsPath (unsafeEncodeUtf) +import qualified GHC.Data.Strict as Strict import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Maybe @@ -297,7 +303,6 @@ import GHC.Cmm.Config (CmmConfig) import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable -import qualified GHC.ByteCode.Serialize as ByteCode {- ********************************************************************** %* * @@ -1185,7 +1190,7 @@ compileWholeCoreBindings hsc_env type_env wcb = do gen_bytecode core_binds stubs foreign_files = do let cgi_guts = CgInteractiveGuts wcb_module core_binds (typeEnvTyCons type_env) stubs foreign_files - Nothing [] + Nothing [] NoHpcInfo trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module) mkModuleByteCode hsc_env wcb_module wcb_mod_location cgi_guts @@ -2135,11 +2140,12 @@ data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module , cgi_foreign_files :: [(ForeignSrcLang, FilePath)] , cgi_modBreaks :: Maybe ModBreaks , cgi_spt_entries :: [SptEntry] + , cgi_hpc_info :: HpcInfo } mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts -mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries} - = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries +mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries, cg_hpc_info} + = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries cg_hpc_info hscInteractive :: HscEnv -> CgInteractiveGuts @@ -2162,13 +2168,15 @@ hscGenerateByteCode :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Compiled hscGenerateByteCode hsc_env cgguts location = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let platform = targetPlatform dflags let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cgi_module = this_mod, cgi_binds = core_binds, cgi_tycons = tycons, cgi_modBreaks = mod_breaks, - cgi_spt_entries = spt_entries } = cgguts + cgi_spt_entries = spt_entries, + cgi_hpc_info = hpc_info } = cgguts ------------------- -- ADD IMPLICIT BINDINGS @@ -2193,8 +2201,22 @@ hscGenerateByteCode hsc_env cgguts location = do let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + ------------------- + -- Setup HPC info + let + -- Strict to not retain a reference to the 'cgguts' via 'hpc_info' + !bytecodeHpcInfo = case hpc_info of + NoHpcInfo -> Strict.Nothing + HpcInfo{hpcInfoTickCount, hpcInfoHash} -> + Strict.Just ByteCodeHpcInfo + { bchi_tick_count = hpcInfoTickCount + , bchi_hash = hpcInfoHash + , bchi_tickboxes = showSDoc dflags $ hpcTickBoxes platform this_mod + , bchi_module_name = showSDoc dflags $ hpcModuleName this_mod + } + ----------------- Generate byte code ------------------ - byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries + byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries bytecodeHpcInfo -- | Generate a byte code object linkable and write it to a file if `-fwrite-byte-code` is enabled. generateAndWriteByteCode :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO ModuleByteCode @@ -2843,6 +2865,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do [] Nothing -- modbreaks [] -- spt entries + Strict.Nothing -- no hpc info {- load it -} bco_time <- getCurrentTime ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3791,12 +3791,6 @@ makeDynFlagsConsistent dflags pgmError (backendDescription (backend dflags) ++ " supports only unregisterised ABI but target platform doesn't use it.") - | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) - = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ - ". Ignoring -fhpc." - in loop dflags' warn - | backendSwappableWithViaC (backend dflags) && platformUnregisterised (targetPlatform dflags) = loop (dflags { backend = viaCBackend }) ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -163,20 +163,20 @@ deSugar hsc_env export_set (typeEnvTyCons type_env) binds else return (binds, Nothing) ; let modBreaks - | Just (_, specs) <- m_tickInfo + | Just (_, _, breakpointSpecs) <- m_tickInfo , breakpointsAllowed dflags - = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs + = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod breakpointSpecs | otherwise = Nothing ; ds_hpc_info <- case m_tickInfo of - Just (orig_file2, ticks) + Just (orig_file2, hpcTicks, _) | gopt Opt_Hpc $ hsc_dflags hsc_env -> do hashNo <- if gopt Opt_Hpc $ hsc_dflags hsc_env - then writeMixEntries (hpcDir dflags) mod ticks orig_file2 + then writeMixEntries (hpcDir dflags) mod hpcTicks orig_file2 else return 0 -- dummy hash when none are written - pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo + pure $ HpcInfo (fromIntegral $ sizeSS hpcTicks) hashNo _ -> pure $ emptyHpcInfo ; (msgs, mb_res) <- initDs hsc_env tcg_env $ ===================================== compiler/GHC/HsToCore/Coverage.hs ===================================== @@ -6,6 +6,9 @@ module GHC.HsToCore.Coverage ( writeMixEntries , hpcInitCode + , hpcStubLabel + , hpcModuleName + , hpcTickBoxes ) where import GHC.Prelude as Prelude @@ -116,24 +119,33 @@ hpcInitCode _ _ (NoHpcInfo {}) = mempty hpcInitCode platform this_mod (HpcInfo tickCount hashNo) = initializerCStub platform fn_name decls body where - fn_name = mkInitializerStubLabel this_mod (fsLit "hpc") + fn_name = hpcStubLabel this_mod decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi body = text "hs_hpc_module" <> parens (hcat (punctuate comma [ - doubleQuotes full_name_str, + doubleQuotes (hpcModuleName this_mod), int tickCount, -- really StgWord32 int hashNo, -- really StgWord32 tickboxes ])) <> semi + tickboxes = hpcTickBoxes platform this_mod - tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod) - - module_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (moduleNameFS (moduleName this_mod))) - package_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (unitFS (moduleUnit this_mod))) - full_name_str - | moduleUnit this_mod == mainUnit - = module_name - | otherwise - = package_name <> char '/' <> module_name +hpcStubLabel :: Module -> CLabel +hpcStubLabel this_mod = mkInitializerStubLabel this_mod (fsLit "hpc") + +hpcModuleName :: Module -> SDoc +hpcModuleName this_mod = full_name_str + where + full_name_str + | moduleUnit this_mod == mainUnit + = module_name + | otherwise + = package_name <> char '/' <> module_name + module_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (moduleNameFS (moduleName this_mod))) + + package_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (unitFS (moduleUnit this_mod))) + +hpcTickBoxes :: Platform -> Module -> SDoc +hpcTickBoxes platform this_mod = pprCLabel platform (mkHpcTicksLabel this_mod) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -100,7 +100,7 @@ addTicksToBinds -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module -> LHsBinds GhcTc - -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick)) + -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg mod mod_loc exports tyCons binds @@ -133,12 +133,13 @@ addTicksToBinds logger cfg (binds1,st) = foldr tickPass (binds, initTTState) passes - extendedMixEntries = ticks st + hpcEntries = hpcTicks st + breakpointEntries = breakpointTicks st putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) - return (binds1, Just (orig_file2, extendedMixEntries)) + return (binds1, Just (orig_file2, hpcEntries, breakpointEntries)) | otherwise = return (binds, Nothing) @@ -1050,23 +1051,31 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) = (addTickLHsExpr e2) (addTickLHsExpr e3) -data TickTransState = TT { ticks :: !(SizedSeq Tick) - , ccIndices :: !CostCentreState - , recSelTicks :: !(IdEnv CoreTickish) +data TickTransState = TT { hpcTicks :: !(SizedSeq Tick) + , breakpointTicks :: !(SizedSeq Tick) + , ccIndices :: !CostCentreState + , recSelTicks :: !(IdEnv CoreTickish) } initTTState :: TickTransState -initTTState = TT { ticks = emptySS - , ccIndices = newCostCentreState - , recSelTicks = emptyVarEnv +initTTState = TT { hpcTicks = emptySS + , breakpointTicks = emptySS + , ccIndices = newCostCentreState + , recSelTicks = emptyVarEnv } -addMixEntry :: Tick -> TM Int -addMixEntry ent = do - c <- fromIntegral . sizeSS . ticks <$> getState +addHpcEntry :: Tick -> TM Int +addHpcEntry ent = do + c <- fromIntegral . sizeSS . hpcTicks <$> getState setState $ \st -> - st { ticks = addToSS (ticks st) ent - } + st { hpcTicks = addToSS (hpcTicks st) ent } + return c + +addBreakpointEntry :: Tick -> TM Int +addBreakpointEntry ent = do + c <- fromIntegral . sizeSS . breakpointTicks <$> getState + setState $ \st -> + st { breakpointTicks = addToSS (breakpointTicks st) ent } return c addRecSelTick :: Id -> CoreTickish -> TM () @@ -1291,7 +1300,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do env <- getEnv case tickishType env of - HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me + HpcTicks -> HpcTick (this_mod env) <$> addHpcEntry me ProfNotes -> do flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name @@ -1300,7 +1309,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do return $ ProfNote cc count True{-scopes-} Breakpoints -> do - i <- addMixEntry me + i <- addBreakpointEntry me pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> @@ -1325,19 +1334,19 @@ mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc mkBinTickBoxHpc boxLabel pos e = do env <- getEnv binTick <- HsBinTick - <$> addMixEntry (Tick { tick_loc = pos + <$> addHpcEntry (Tick { tick_loc = pos , tick_path = declPath env , tick_ids = [] , tick_label = boxLabel True }) - <*> addMixEntry (Tick { tick_loc = pos + <*> addHpcEntry (Tick { tick_loc = pos , tick_path = declPath env , tick_ids = [] , tick_label = boxLabel False }) <*> pure e tick <- HpcTick (this_mod env) - <$> addMixEntry (Tick { tick_loc = pos + <$> addHpcEntry (Tick { tick_loc = pos , tick_path = declPath env , tick_ids = [] , tick_label = ExpBox False ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -402,6 +402,7 @@ tidyProgram opts (ModGuts { mg_module = mod , mg_foreign_files = foreign_files , mg_modBreaks = modBreaks , mg_boot_exports = boot_exports + , mg_hpc_info = hpc_info }) = do (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod tcs binds imp_rules @@ -471,6 +472,7 @@ tidyProgram opts (ModGuts { mg_module = mod , cg_dep_pkgs = S.map snd (dep_direct_pkgs deps) , cg_modBreaks = modBreaks , cg_spt_entries = spt_entries + , cg_hpc_info = hpc_info } , ModDetails { md_types = tidy_type_env , md_rules = tidy_rules ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -137,6 +137,10 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M import Foreign.Ptr (nullPtr) import GHC.ByteCode.Serialize +-- TODO: this import is wrong +import GHC.HsToCore.Coverage (hpcModuleName) +import qualified Data.ByteString.Char8 as BS8 +import qualified GHC.Data.Strict as Strict -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -983,10 +987,9 @@ dynLinkBCOs interp pls keep_spec bcos = let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } - cbcs :: [CompiledByteCode] - cbcs = concatMap linkableBCOs new_bcos + mbcs = concatMap linkableBCOs new_bcos in do - bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec cbcs + bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec mbcs return $! pls1 { bco_loader_state = bco_state } dynLinkCompiledByteCode :: Interp @@ -996,22 +999,22 @@ dynLinkCompiledByteCode :: Interp -> KeepModuleLinkableDefinitions -> [CompiledByteCode] -> IO BytecodeLoaderState -dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec cbcs = do +dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec mbcs = do st1 <- traverse_bytecode_state whole_bytecode_state $ \bytecode_state -> do let le1 = bco_linker_env bytecode_state lb1 = bco_linked_breaks bytecode_state - ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) - ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs - be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs) - ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs) + ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls mbcs) + ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) mbcs + be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks mbcs) + ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks mbcs) let le2 = le1 { itbl_env = ie2, addr_env = ae2 } let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } return $! bytecode_state { bco_linker_env = le2, bco_linked_breaks = lb2 } -- NB: Important to pass the whole bytecode loader state to linkSomeBCOs so that you can find Names in local -- and external packages. - names_and_refs <- linkSomeBCOs interp pkgs_loaded st1 cbcs + names_and_refs <- linkSomeBCOs interp pkgs_loaded st1 mbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (keepDefinitions keep_spec . fst) names_and_refs @@ -1024,7 +1027,9 @@ dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecod traverse_bytecode_state st1 $ \bytecode_state -> do let ce2 = extendClosureEnv (closure_env (bco_linker_env bytecode_state)) new_binds -- Add SPT entries - mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) + mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries mbcs) + -- Load HPC modules + mapM_ (linkHpcEntry interp . bc_hpc_info) mbcs return $! bytecode_state { bco_linker_env = (bco_linker_env bytecode_state) { closure_env = ce2 } } -- | Register SPT entries for this module in the interpreter @@ -1037,8 +1042,14 @@ linkSptEntry interp ce (SptEntry name fpr) = do Nothing -> pprPanic "linkSptEntry" (ppr name) Just (_, hval) -> addSptEntry interp fpr hval - - +linkHpcEntry :: Interp -> Strict.Maybe ByteCodeHpcInfo -> IO () +linkHpcEntry _interp Strict.Nothing = pure () +linkHpcEntry interp (Strict.Just info) = do + addHpcModule interp + (bchi_module_name info) + (bchi_tick_count info) + (bchi_hash info) + (bchi_tickboxes info) -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -214,36 +214,37 @@ data BytecodeLoaderState = BytecodeLoaderState -- ^ Information about bytecode objects from the home package we have loaded into the interpreter. , externalPackage_loaded :: BytecodeState -- ^ Information about bytecode objects from external packages we have loaded into the interpreter. + , hpcInitialised :: !Bool } -- | Find a name loaded from bytecode lookupNameBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue) -lookupNameBytecodeState (BytecodeLoaderState home_package external_package) name = do +lookupNameBytecodeState (BytecodeLoaderState home_package external_package _) name = do lookupNameEnv (closure_env (bco_linker_env home_package)) name <|> lookupNameEnv (closure_env (bco_linker_env external_package)) name -- | Look up a break array in the bytecode loader state. lookupBreakArrayBytecodeState :: BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray) -lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package) break_mod = do +lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package _) break_mod = do lookupModuleEnv (breakarray_env (bco_linked_breaks home_package)) break_mod <|> lookupModuleEnv (breakarray_env (bco_linked_breaks external_package)) break_mod -- | Look up an info table in the bytecode loader state. lookupInfoTableBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr) -lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package) info_mod = do +lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package _) info_mod = do lookupNameEnv (itbl_env (bco_linker_env home_package)) info_mod <|> lookupNameEnv (itbl_env (bco_linker_env external_package)) info_mod -- | Look up an address in the bytecode loader state. lookupAddressBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr) -lookupAddressBytecodeState (BytecodeLoaderState home_package external_package) addr_mod = do +lookupAddressBytecodeState (BytecodeLoaderState home_package external_package _) addr_mod = do lookupNameEnv (addr_env (bco_linker_env home_package)) addr_mod <|> lookupNameEnv (addr_env (bco_linker_env external_package)) addr_mod -- | Look up a cost centre stack in the bytecode loader state. lookupCCSBytecodeState :: BytecodeLoaderState -> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre)) -lookupCCSBytecodeState (BytecodeLoaderState home_package external_package) ccs_mod = do +lookupCCSBytecodeState (BytecodeLoaderState home_package external_package _) ccs_mod = do lookupModuleEnv (ccs_env (bco_linked_breaks home_package)) ccs_mod <|> lookupModuleEnv (ccs_env (bco_linked_breaks external_package)) ccs_mod @@ -251,6 +252,7 @@ emptyBytecodeLoaderState :: BytecodeLoaderState emptyBytecodeLoaderState = BytecodeLoaderState { homePackage_loaded = emptyBytecodeState , externalPackage_loaded = emptyBytecodeState + , hpcInitialised = False } emptyBytecodeState :: BytecodeState ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Runtime.Interpreter , mallocData , createBCOs , addSptEntry + , addHpcModule , mkCostCentres , costCentreStackInfo , newBreakArray @@ -366,6 +367,10 @@ addSptEntry interp fpr ref = withForeignRef ref $ \val -> interpCmd interp (AddSptEntry fpr val) +addHpcModule :: Interp -> String -> Int -> Int -> String -> IO () +addHpcModule interp modLabel tickNo hash tickboxes = + interpCmd interp (AddHpcModule modLabel tickNo hash tickboxes) + costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String] costCentreStackInfo interp ccs = interpCmd interp (CostCentreStackInfo ccs) ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -20,6 +20,7 @@ import GHC.ByteCode.Types import GHC.Cmm.CallConv import GHC.Cmm.Expr +import GHC.Cmm.CLabel (mkHpcTicksLabel, pprCLabel) import GHC.Cmm.Reg ( GlobalArgRegs(..) ) import GHC.Cmm.Node import GHC.Cmm.Utils @@ -97,6 +98,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State (StateT(..)) import Data.Bifunctor (Bifunctor(..)) +import qualified GHC.Data.Strict as Strict -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -107,8 +109,9 @@ byteCodeGen :: HscEnv -> [TyCon] -> Maybe ModBreaks -> [SptEntry] + -> Strict.Maybe ByteCodeHpcInfo -> IO CompiledByteCode -byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries hpc_info = withTiming logger (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do @@ -134,7 +137,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries let mod_breaks = case mb_modBreaks of Nothing -> Nothing Just mb -> Just $ mkInternalModBreaks this_mod breakInfo mb - cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries + cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries hpc_info -- Squash space leaks in the CompiledByteCode. This is really -- important, because when loading a set of modules into GHCi @@ -604,6 +607,11 @@ schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) = pprPanic "schemeE: Breakpoint without let binding:" (ppr bp_id <+> text "forgot to run bcPrep?") +schemeE d s p (StgTick (HpcTick mod ix) rhs) = do + platform <- profilePlatform <$> getProfile + rhs_code <- schemeE d s p rhs + pure (unitOL (HPC_TICK (mkHpcTickLabel platform mod) (fromIntegral ix)) `appOL` rhs_code) + -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs @@ -2784,6 +2792,10 @@ getLastBreakTick = BcM $ \env st -> tickFS :: FastString tickFS = fsLit "ticked" +mkHpcTickLabel :: Platform -> Module -> FastString +mkHpcTickLabel platform mod = + fsLit (showSDocOneLine defaultSDocContext (pprCLabel platform (mkHpcTicksLabel mod))) + -- Dehydrating CgBreakInfo dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo ===================================== compiler/GHC/Types/HpcInfo.hs ===================================== @@ -18,4 +18,3 @@ data HpcInfo emptyHpcInfo :: HpcInfo emptyHpcInfo = NoHpcInfo - ===================================== compiler/GHC/Unit/Module/ModGuts.hs ===================================== @@ -141,8 +141,9 @@ data CgGuts cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to -- generate #includes for C code gen cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints - cg_spt_entries :: [SptEntry] + cg_spt_entries :: [SptEntry], -- ^ Static pointer table entries for static forms defined in -- the module. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable" + cg_hpc_info :: HpcInfo } ===================================== libraries/ghci/GHCi/Coverage.hs ===================================== @@ -0,0 +1,51 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + +module GHCi.Coverage ( + hpcAddModule, + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +import Control.Exception +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Unsafe as B +import Data.Word +import Foreign +import Foreign.C.String (withCAString) +import GHC.Fingerprint +import GHC.Foreign (CString) +import GHCi.ObjLink (lookupSymbol) + +-- | Inform the run-time system that the given module name is instrumented via @hpc@ +-- and to collect @.tix@ info. +-- +-- Starts the `hpc` run-time if it hasn't already been started. +hpcAddModule :: + String -> + -- ^ Name of the module to instrument + Int -> + -- ^ Number of hpc ticks in this module + Int -> + -- ^ 'HpcInfo's 'hpcInfoHash' + String -> + -- ^ Name of the ticks array found in the c-stub. + IO () +hpcAddModule modlName ticks hash tickboxes = do + withCAString 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 " <> 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 + +foreign import ccall "hs_hpc_module" + hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO () + +foreign import ccall "startupHpc" + hpc_startup :: IO () ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -111,6 +111,8 @@ data Message a where -- | Add entries to the Static Pointer Table AddSptEntry :: Fingerprint -> HValueRef -> Message () + -- | Add module to hpc + AddHpcModule :: String -> Int -> Int -> String -> Message () -- | Malloc some data and return a 'RemotePtr' to it MallocData :: ByteString -> Message (RemotePtr ()) @@ -607,7 +609,8 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) - 41 -> Msg <$> (CustomMessage <$> get <*> get) + 41 -> Msg <$> (AddHpcModule <$> get <*> get <*> get <*> get) + 42 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -654,7 +657,8 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a - CustomMessage tag payload -> putWord8 41 >> put tag >> put payload + AddHpcModule m n h ticks -> putWord8 41 >> put m >> put n >> put h >> put ticks + CustomMessage tag payload -> putWord8 42 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -19,6 +19,7 @@ import GHCi.CreateBCO import GHCi.InfoTable #endif +import GHCi.Coverage import qualified GHC.InfoProv as InfoProv import GHCi.Debugger import GHCi.FFI @@ -88,6 +89,7 @@ run m = case m of fmap toRemotePtr <$> lookupSymbolInDLL (fromRemotePtr dll) str FreeHValueRefs rs -> mapM_ freeRemoteRef rs AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr + AddHpcModule modl ticks hash tickboxes -> hpcAddModule modl ticks hash tickboxes EvalStmt opts r -> evalStmt opts r ResumeStmt opts r -> resumeStmt opts r AbandonStmt r -> abandonStmt r ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -59,6 +59,7 @@ library if flag(internal-interpreter) CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: + GHCi.Coverage GHCi.Run GHCi.Debugger GHCi.CreateBCO ===================================== rts/Disassembler.c ===================================== @@ -101,6 +101,13 @@ disInstr ( StgBCO *bco, int pc ) } debugBelch("\n"); break; } + case bci_HPC_TICK: { + W_ p1, info_wix; + p1 = BCO_GET_LARGE_ARG; + info_wix = BCO_READ_NEXT_32; + debugBelch("HPC_TICK "); printPtr((StgPtr)literals[p1]); + debugBelch(" %" FMT_Word "\n", info_wix); + break; } case bci_SWIZZLE: { W_ stkoff = BCO_GET_LARGE_ARG; StgInt by = BCO_GET_LARGE_ARG; ===================================== rts/Hpc.c ===================================== @@ -270,6 +270,9 @@ hs_hpc_module(char *modName, HpcModuleInfo *tmpModule; uint32_t i; + debugTrace(DEBUG_hpc, "hs_hpc_module(%s, count=%u, hash=%u)\n", + modName, modCount, modHashNo); + if (moduleHash == NULL) { moduleHash = allocStrHashTable(); } ===================================== rts/Interpreter.c ===================================== @@ -1711,7 +1711,7 @@ run_BCO: &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT, &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT, &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT, - &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT, + &&lbl_bci_HPC_TICK - &&lbl_bci_DEFAULT, &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT, &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT, &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT, @@ -2078,6 +2078,18 @@ run_BCO: NEXT_INSTRUCTION; } + INSTRUCTION(bci_HPC_TICK): { + W_ arg1_ticks_array, arg2_tick_index; + arg1_ticks_array = BCO_GET_LARGE_ARG; + arg2_tick_index = BCO_READ_NEXT_32; + IF_DEBUG(hpc, + debugBelch("\tHPC Tick %lu %lu %lu\n", BCO_LIT(arg1_ticks_array), arg1_ticks_array, arg2_tick_index); + ); + + ((StgWord64*)BCO_LIT(arg1_ticks_array))[arg2_tick_index]++; + NEXT_INSTRUCTION; + } + INSTRUCTION(bci_STKCHECK): { // Explicit stack check at the beginning of a function // *only* (stack checks in case alternatives are ===================================== rts/include/rts/Bytecodes.h ===================================== @@ -118,6 +118,7 @@ #define bci_PRIMCALL 87 #define bci_BCO_NAME 88 +#define bci_HPC_TICK 89 #define bci_OP_ADD_64 90 #define bci_OP_SUB_64 91 ===================================== testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs ===================================== @@ -0,0 +1,10 @@ +module Main where + +inc :: Int -> Int +inc x = x + 1 + +double :: Int -> Int +double x = x * 2 + +main :: IO () +main = print (double (inc 1011)) ===================================== testsuite/tests/hpc/ghc_ghci/Makefile ===================================== @@ -7,3 +7,9 @@ hpc_ghc_ghci: '$(TEST_HC)' $(TEST_HC_OPTS) -fhpc -c A.hs echo b | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) B.hs +hpc_ghc_ghci_bytecode: + rm -f ./*.tix + printf "main\n:quit\n" | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -fhpc -fbyte-code-and-object-code -fprefer-byte-code BytecodeMain.hs + @[ -f .hpc/Main.mix ] || (echo "ERROR: Expected .hpc/Main.mix file not found"; exit 1) + @set -- ./*.tix; [ -f "$$1" ] || (echo "ERROR: Expected .tix file not found"; exit 1); '$(HPC)' report "$$1" Main > hpc-report.txt + @grep -F "100% expressions used" hpc-report.txt >/dev/null || (echo "ERROR: Expected full expression coverage in hpc report"; cat hpc-report.txt; exit 1) ===================================== testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout ===================================== @@ -0,0 +1 @@ +2024 ===================================== testsuite/tests/hpc/ghc_ghci/test.T ===================================== @@ -3,3 +3,8 @@ test('hpc_ghc_ghci', [extra_files(['A.hs', 'B.hs']), only_ways(['normal']), when(compiler_profiled(), skip), req_interp], run_command, ['$MAKE -s --no-print-directory hpc_ghc_ghci']) + +test('hpc_ghc_ghci_bytecode', + [extra_files(['BytecodeMain.hs']), + only_ways(['normal']), when(compiler_profiled(), skip), req_interp], + run_command, ['$MAKE -s --no-print-directory hpc_ghc_ghci_bytecode']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/467794d84015c454aa5a38951d3a7c12... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/467794d84015c454aa5a38951d3a7c12... You're receiving this email because of your account on gitlab.haskell.org.