Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 79bda793 by Matthew Pickering at 2026-03-17T10:51:41+01:00 Emit initialisers/finalisers when creating CStubs - - - - - 60d51a25 by Matthew Pickering at 2026-03-17T10:51:41+01:00 WIP: Fix -fhpc with the interpreter - - - - - a238bd42 by Matthew Pickering at 2026-03-17T10:51:41+01:00 Use separate tick array for hpc/breakpoint ticks - - - - - 56dce546 by Matthew Pickering at 2026-03-17T10:51:41+01:00 Fix label printing - - - - - 16 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/StgToByteCode.hs - 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 ===================================== @@ -855,6 +855,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 @@ -577,6 +580,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/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 ===================================== @@ -276,14 +276,15 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs NoStubs -> return (False, Nothing) - ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do + ForeignStubs (CHeader h_code) cstub -> do let - stub_c_output_d = pprCode c_code + stub_c_output_d = pprCode (getCStub cstub $$ pprCStubInitFiniDecls platform 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" @@ -343,6 +344,28 @@ 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 ".init_array") [0 :: Int ..] (getInitializers cstub)) + $$ vcat (zipWith (pprInitOrFiniDecl ".fini_array") [0 :: Int ..] (getFinalizers cstub)) + where + pprInitOrFiniDecl :: String -> Int -> CLabel -> SDoc + pprInitOrFiniDecl section_name n lbl = + vcat + [ hsep [text "extern void", pprCLabel platform lbl, text "(void);"] + , hsep [ text "static void (*" + <> text "__ghc_init_fini_" + <> 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. ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3790,12 +3790,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/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) @@ -1049,23 +1050,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 () @@ -1290,7 +1299,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 @@ -1299,7 +1308,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 -> @@ -1324,19 +1333,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/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 @@ -73,6 +74,7 @@ import Data.List ( genericReplicate, intersperse import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char +import Data.Word import GHC.Unit.Module @@ -603,6 +605,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 @@ -2767,6 +2774,10 @@ getLastBreakTick = BcM $ \env st -> tickFS :: FastString tickFS = fsLit "ticked" +mkHpcTickLabel :: Platform -> Module -> FastString +mkHpcTickLabel platform mod = + fsLit (showSDocOneLine defaultSDocContext (pprCode (pprCLabel platform (mkHpcTicksLabel mod)))) + -- Dehydrating CgBreakInfo dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo ===================================== 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(); } @@ -320,6 +323,8 @@ hs_hpc_module(char *modName, } tmpModule->from_file = false; } + + startupHpc(); } static void ===================================== rts/Interpreter.c ===================================== @@ -1739,6 +1739,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_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, @@ -2106,6 +2107,15 @@ 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; + + ((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/-/compare/18fd0df60d827ec1c4c84aad2283570... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/18fd0df60d827ec1c4c84aad2283570... You're receiving this email because of your account on gitlab.haskell.org.