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
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:
| ... | ... | @@ -124,3 +124,6 @@ |
| 124 | 124 | [submodule "libraries/template-haskell-quasiquoter"]
|
| 125 | 125 | path = libraries/template-haskell-quasiquoter
|
| 126 | 126 | url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git
|
| 127 | +[submodule "eventlog-live-profiling-prototype"]
|
|
| 128 | + path = eventlog-live-profiling-prototype
|
|
| 129 | + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git |
| 1 | +Subproject commit b575347b8d17703e9ab77cf998c680fc60039096 |
| ... | ... | @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr |
| 80 | 80 | import GHC.Driver.Session.Mode
|
| 81 | 81 | import GHC.Driver.Session.Lint
|
| 82 | 82 | import GHC.Driver.Session.Units
|
| 83 | +import GHC.Driver.Monad
|
|
| 83 | 84 | |
| 84 | 85 | -- Standard Haskell libraries
|
| 85 | 86 | import System.IO
|
| ... | ... | @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) |
| 91 | 92 | import Data.List ( isPrefixOf, partition, intercalate )
|
| 92 | 93 | import Prelude
|
| 93 | 94 | import qualified Data.List.NonEmpty as NE
|
| 95 | +#if defined(SAMPLE_TRACER)
|
|
| 96 | +import qualified GHC.Stack.Profiler.Sampler as Sampler
|
|
| 97 | +#endif
|
|
| 98 | + |
|
| 99 | +runWithStackProfiler :: IO () -> IO ()
|
|
| 100 | +runWithStackProfiler =
|
|
| 101 | +#if defined(SAMPLE_TRACER)
|
|
| 102 | + Sampler.withStackProfiler (Sampler.SampleIntervalMs 10)
|
|
| 103 | +#else
|
|
| 104 | + id
|
|
| 105 | +#endif
|
|
| 94 | 106 | |
| 95 | 107 | -----------------------------------------------------------------------------
|
| 96 | 108 | -- ToDo:
|
| ... | ... | @@ -153,7 +165,8 @@ main = do |
| 153 | 165 | ShowGhciUsage -> showGhciUsage dflags
|
| 154 | 166 | PrintWithDynFlags f -> putStrLn (f dflags)
|
| 155 | 167 | Right postLoadMode ->
|
| 156 | - main' postLoadMode units dflags argv3 flagWarnings
|
|
| 168 | + reifyGhc $ \session -> runWithStackProfiler $
|
|
| 169 | + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
|
|
| 157 | 170 | |
| 158 | 171 | main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
|
| 159 | 172 | -> Ghc ()
|
| ... | ... | @@ -27,6 +27,11 @@ Flag threaded |
| 27 | 27 | Default: True
|
| 28 | 28 | Manual: True
|
| 29 | 29 | |
| 30 | +Flag sampleTracer
|
|
| 31 | + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled
|
|
| 32 | + Default: False
|
|
| 33 | + Manual: True
|
|
| 34 | + |
|
| 30 | 35 | Executable ghc
|
| 31 | 36 | Default-Language: GHC2021
|
| 32 | 37 | |
| ... | ... | @@ -45,6 +50,10 @@ Executable ghc |
| 45 | 50 | ghc-boot == @ProjectVersionMunged@,
|
| 46 | 51 | ghc == @ProjectVersionMunged@
|
| 47 | 52 | |
| 53 | + if flag(sampleTracer)
|
|
| 54 | + build-depends: ghc-stack-profiler
|
|
| 55 | + CPP-OPTIONS: -DSAMPLE_TRACER
|
|
| 56 | + |
|
| 48 | 57 | if os(windows)
|
| 49 | 58 | Build-Depends: Win32 >= 2.3 && < 2.15
|
| 50 | 59 | else
|
| ... | ... | @@ -13,6 +13,7 @@ module Packages ( |
| 13 | 13 | transformers, unlit, unix, win32, xhtml,
|
| 14 | 14 | lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
|
| 15 | 15 | ghcPackages, isGhcPackage,
|
| 16 | + ghc_stack_profiler, ghc_stack_profiler_core,
|
|
| 16 | 17 | |
| 17 | 18 | -- * Package information
|
| 18 | 19 | crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath,
|
| ... | ... | @@ -43,7 +44,9 @@ ghcPackages = |
| 43 | 44 | , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio
|
| 44 | 45 | , timeout
|
| 45 | 46 | , lintersCommon
|
| 46 | - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
|
|
| 47 | + , ghc_stack_profiler_core
|
|
| 48 | + , ghc_stack_profiler
|
|
| 49 | + ]
|
|
| 47 | 50 | |
| 48 | 51 | -- TODO: Optimise by switching to sets of packages.
|
| 49 | 52 | isGhcPackage :: Package -> Bool
|
| ... | ... | @@ -135,6 +138,8 @@ unlit = util "unlit" |
| 135 | 138 | unix = lib "unix"
|
| 136 | 139 | win32 = lib "Win32"
|
| 137 | 140 | xhtml = lib "xhtml"
|
| 141 | +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "eventlog-live-profiling-prototype/ghc-stack-profiler"
|
|
| 142 | +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "eventlog-live-profiling-prototype/ghc-stack-profiler-core"
|
|
| 138 | 143 | |
| 139 | 144 | lintersCommon = lib "linters-common" `setPath` "linters/linters-common"
|
| 140 | 145 | lintNotes = linter "lint-notes"
|
| ... | ... | @@ -180,6 +180,8 @@ stage1Packages = do |
| 180 | 180 | , unlit
|
| 181 | 181 | , xhtml
|
| 182 | 182 | , if winTarget then win32 else unix
|
| 183 | + , ghc_stack_profiler
|
|
| 184 | + , ghc_stack_profiler_core
|
|
| 183 | 185 | ]
|
| 184 | 186 | , when (not cross)
|
| 185 | 187 | [ hpcBin
|
| ... | ... | @@ -108,6 +108,12 @@ packageArgs = do |
| 108 | 108 | |
| 109 | 109 | , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ]
|
| 110 | 110 | |
| 111 | + , package ghc_stack_profiler ? mconcat
|
|
| 112 | + [ builder (Cabal Flags) ? mconcat
|
|
| 113 | + [ arg "-use-ghc-trace-events"
|
|
| 114 | + ]
|
|
| 115 | + ]
|
|
| 116 | + |
|
| 111 | 117 | ---------------------------------- ghc ---------------------------------
|
| 112 | 118 | , package ghc ? mconcat
|
| 113 | 119 | [ builder Ghc ? mconcat
|
| ... | ... | @@ -116,6 +122,7 @@ packageArgs = do |
| 116 | 122 | |
| 117 | 123 | , builder (Cabal Flags) ? mconcat
|
| 118 | 124 | [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter"
|
| 125 | + , notStage0 `cabalFlag` "sampleTracer"
|
|
| 119 | 126 | , ifM stage0
|
| 120 | 127 | -- We build a threaded stage 1 if the bootstrapping compiler
|
| 121 | 128 | -- supports it.
|