Hannes Siebenhandl pushed to branch wip/fendor/ghc-stack-profiler at Glasgow Haskell Compiler / GHC Commits: f73bb784 by fendor at 2025-11-03T17:50:48+01:00 Sample Profiler commit - - - - - 7 changed files: - .gitmodules - + eventlog-live-profiling-prototype - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs Changes: ===================================== .gitmodules ===================================== @@ -124,3 +124,6 @@ [submodule "libraries/template-haskell-quasiquoter"] path = libraries/template-haskell-quasiquoter url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git +[submodule "eventlog-live-profiling-prototype"] + path = eventlog-live-profiling-prototype + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git ===================================== eventlog-live-profiling-prototype ===================================== @@ -0,0 +1 @@ +Subproject commit b575347b8d17703e9ab77cf998c680fc60039096 ===================================== ghc/Main.hs ===================================== @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr import GHC.Driver.Session.Mode import GHC.Driver.Session.Lint import GHC.Driver.Session.Units +import GHC.Driver.Monad -- Standard Haskell libraries import System.IO @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(SAMPLE_TRACER) +import qualified GHC.Stack.Profiler.Sampler as Sampler +#endif + +runWithStackProfiler :: IO () -> IO () +runWithStackProfiler = +#if defined(SAMPLE_TRACER) + Sampler.withStackProfiler (Sampler.SampleIntervalMs 10) +#else + id +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -153,7 +165,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithStackProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,6 +27,11 @@ Flag threaded Default: True Manual: True +Flag sampleTracer + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -45,6 +50,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-stack-profiler + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -13,6 +13,7 @@ module Packages ( transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, + ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +44,9 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , ghc_stack_profiler_core + , ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -135,6 +138,8 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "eventlog-live-profiling-prototype/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "eventlog-live-profiling-prototype/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -180,6 +180,8 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_stack_profiler + , ghc_stack_profiler_core ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -108,6 +108,12 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_stack_profiler ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat @@ -116,6 +122,7 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f73bb7844a7cd7437ba2c92140aae6fc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f73bb7844a7cd7437ba2c92140aae6fc... You're receiving this email because of your account on gitlab.haskell.org.