Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 6832ae44 by fendor at 2026-04-02T10:04:24+02:00 Make HPC work with bytecode interpreter - - - - - 20 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/ByteCode.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/Hpc.c - rts/Interpreter.c Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -71,6 +71,7 @@ import GHC.Float (castFloatToWord32, castDoubleToWord64) import qualified Data.List as List ( any ) import GHC.Exts +import qualified GHC.Data.Strict as Strict -- ----------------------------------------------------------------------------- @@ -110,8 +111,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 @@ -122,6 +124,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] ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -295,13 +295,15 @@ instance Binary CompiledByteCode where replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh bc_breaks <- get bh bc_spt_entries <- get bh + bc_hpc_info <- get bh return $ CompiledByteCode { bc_bcos, bc_itbls, bc_strs, bc_breaks, - bc_spt_entries + bc_spt_entries, + bc_hpc_info } put_ bh CompiledByteCode {..} = do @@ -314,6 +316,26 @@ instance Binary CompiledByteCode where for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str put_ bh bc_breaks put_ bh bc_spt_entries + put_ bh bc_hpc_info + +instance Binary ByteCodeHpcInfo where + put_ bh ByteCodeHpcInfo{bchi_tick_count,bchi_hash,bchi_tickboxes,bchi_module_name} = do + put_ bh bchi_tick_count + put_ bh bchi_hash + put_ bh bchi_tickboxes + put_ bh bchi_module_name + + get bh = do + bchi_tick_count <- get bh + bchi_hash <- get bh + bchi_tickboxes <- get bh + bchi_module_name <- get bh + pure ByteCodeHpcInfo + { bchi_tick_count + , bchi_hash + , bchi_tickboxes + , bchi_module_name + } instance Binary UnlinkedBCO where get bh = ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -22,6 +22,9 @@ module GHC.ByteCode.Types -- * Mod Breaks , ModBreaks (..), BreakpointId(..), BreakTickIndex + -- * Hpc Info + , ByteCodeHpcInfo(..) + -- * Internal Mod Breaks , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks -- ** Internal breakpoint identifier @@ -32,6 +35,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 @@ -76,6 +80,14 @@ 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) -- ^ TODO: @fendor + } + +data ByteCodeHpcInfo = ByteCodeHpcInfo + { bchi_tick_count :: {-# UNPACK #-} !Int + , bchi_hash :: {-# UNPACK #-} !Int + , bchi_tickboxes :: !ByteString + , bchi_module_name :: !ByteString } -- | A libffi ffi_cif function prototype. ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -278,13 +278,12 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs ForeignStubs (CHeader h_code) cstub -> do let - stub_c_output_d = pprCode (getCStub cstub $$ pprCStubInitFiniDecls platform cstub) + stub_c_output_d = pprCode (getCStub cstub) stub_c_output_w = showSDoc dflags stub_c_output_d -- Header file protos for "foreign export"ed functions. stub_h_output_d = pprCode h_code stub_h_output_w = showSDoc dflags stub_h_output_d - platform = targetPlatform dflags putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export header file" @@ -344,29 +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" -pprCStubInitFiniDecls :: Platform -> CStub -> SDoc -pprCStubInitFiniDecls platform cstub = - vcat (zipWith (pprInitOrFiniDecl "ini" ".init_array") [0 :: Int ..] (getInitializers cstub)) - $$ vcat (zipWith (pprInitOrFiniDecl "fini" ".fini_array") [0 :: Int ..] (getFinalizers cstub)) - where - pprInitOrFiniDecl :: String -> String -> Int -> CLabel -> SDoc - pprInitOrFiniDecl suf section_name n lbl = - vcat - [ hsep [text "extern void", pprCLabel platform lbl, text "(void);"] - , hsep [ text "static void (*" - <> text "__ghc_" <> text suf <> text "_" - <> int n - <> text ")(void)" - , text "__attribute__((used, section(" - <> doubleQuotes (text section_name) - <> text ")))" - , equals - , pprCLabel platform lbl - <> semi - ] - ] - - -- 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 ===================================== @@ -151,6 +151,7 @@ import GHC.Hs.Dump import GHC.Hs.Stats ( ppSourceStats ) import GHC.HsToCore +import GHC.HsToCore.Coverage ( hpcTickBoxes ) import GHC.StgToByteCode ( byteCodeGen ) import GHC.StgToJS ( stgToJS ) @@ -237,6 +238,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 @@ -299,6 +301,9 @@ import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable import GHC.ByteCode.Serialize +import GHC.Driver.Ppr (showSDoc) +import qualified Data.ByteString.Char8 as BS8 +import qualified GHC.Data.Strict as Strict {- ********************************************************************** %* * @@ -1186,7 +1191,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 @@ -2136,11 +2141,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 @@ -2163,13 +2169,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 @@ -2194,8 +2202,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 'CgInteractiveGuts' of 'cgguts' + !bytecodeHpcInfo = case hpc_info of + NoHpcInfo -> Strict.Nothing + HpcInfo{hpcInfoTickCount, hpcInfoHash} -> + Strict.Just ByteCodeHpcInfo + { bchi_tick_count = hpcInfoTickCount + , bchi_hash = hpcInfoHash + , bchi_tickboxes = BS8.pack . (++ "\0") . showSDoc dflags $ hpcTickBoxes platform this_mod + , bchi_module_name = BS8.pack . (++ "\0") . showSDoc dflags $ ppr 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 @@ -2844,6 +2866,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do [] Nothing -- modbreaks [] -- spt entries + Strict.Nothing -- no hpc info {- load it -} bco_time <- getCurrentTime ===================================== 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/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/ByteCode.hs ===================================== @@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files = return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name) Nothing -> pure Nothing False -> do - pure $ Just (InterpreterStaticObjects files) \ No newline at end of file + pure $ Just (InterpreterStaticObjects files) ===================================== 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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -988,10 +992,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 @@ -1001,22 +1004,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 @@ -1029,7 +1032,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 @@ -1042,8 +1047,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 ===================================== @@ -204,36 +204,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 @@ -241,6 +242,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 -> ByteString -> Int -> Int -> ByteString -> 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 ===================================== @@ -74,7 +74,6 @@ import Data.List ( genericReplicate, intersperse import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char -import Data.Word import GHC.Unit.Module @@ -98,6 +97,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 @@ -108,8 +108,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 @@ -135,7 +136,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 ===================================== 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,32 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + +module GHCi.Coverage ( hpcAddModule ) where + +import Prelude -- See note [Why do we import Prelude here?] +import Data.Word +import Foreign +import GHC.Fingerprint +import GHCi.RemoteTypes +import Data.ByteString +import GHC.Foreign (CString) +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Char8 as BS8 +import GHCi.ObjLink (lookupSymbol) +import Debug.Trace + +hpcAddModule :: ByteString -> Int -> Int -> ByteString -> IO () +hpcAddModule modl ticks hash tickboxes = do + B.unsafeUseAsCString modl $ \modlLiteral -> do + lookupSymbol (BS8.unpack tickboxes) >>= \ case + Nothing -> pure () + Just tickBoxRef -> do + hpc_register_module modlLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) + 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 :: ByteString -> Int -> Int -> ByteString -> Message () -- | Malloc some data and return a 'RemotePtr' to it MallocData :: ByteString -> Message (RemotePtr ()) @@ -602,6 +604,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (AddHpcModule <$> get <*> get <*> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +651,7 @@ 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 + AddHpcModule lbl ticks hash tickboxes -> putWord8 41 >> put lbl >> put ticks >> put hash >> put tickboxes {- 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/Hpc.c ===================================== @@ -323,8 +323,6 @@ hs_hpc_module(char *modName, } tmpModule->from_file = false; } - - startupHpc(); } static void ===================================== rts/Interpreter.c ===================================== @@ -1740,7 +1740,6 @@ run_BCO: &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT, &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT, &&lbl_bci_HPC_TICK - &&lbl_bci_DEFAULT, - &&lbl_bci_DEFAULT - &&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, @@ -2111,6 +2110,9 @@ run_BCO: 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; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6832ae4471e3f75e4484e078689209d1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6832ae4471e3f75e4484e078689209d1... You're receiving this email because of your account on gitlab.haskell.org.