Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC Commits: 038027a4 by Matthew Pickering at 2026-04-13T18:08:03+02:00 Add support for instrumenting with eventlog-socket - - - - - 732458e0 by fendor at 2026-04-13T18:08:03+02:00 Support for `ghc-stack-profiler` Instrument GHC to run with `ghc-stack-profiler` - - - - - 12 changed files: - .gitmodules - + eventlog-socket - + ghc-stack-profiler - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Builders/Hsc2Hs.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + libraries/async - + libraries/hashable - + libraries/unordered-containers Changes: ===================================== .gitmodules ===================================== @@ -123,3 +123,18 @@ [submodule "libraries/libffi-clib"] path = libraries/libffi-clib url = https://gitlab.haskell.org/ghc/libffi-clib.git +[submodule "eventlog-socket"] + path = eventlog-socket + url = https://github.com/well-typed/eventlog-socket.git +[submodule "ghc-stack-profiler"] + path = ghc-stack-profiler + url = https://github.com/well-typed/ghc-stack-profiler +[submodule "libraries/async"] + path = libraries/async + url = https://github.com/fendor/async.git +[submodule "libraries/unordered-containers"] + path = libraries/unordered-containers + url = https://github.com/fendor/unordered-containers.git +[submodule "libraries/hashable"] + path = libraries/hashable + url = https://github.com/fendor/hashable ===================================== eventlog-socket ===================================== @@ -0,0 +1 @@ +Subproject commit c7f760dfda6888cc63ea5be1d43b42aa6e8a0f2a ===================================== ghc-stack-profiler ===================================== @@ -0,0 +1 @@ +Subproject commit cecf5ae647da4bc505a8a8bbff21400ef070065c ===================================== ghc/Main.hs ===================================== @@ -79,6 +79,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 @@ -90,6 +91,23 @@ 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 as Profiler +#endif + +#if defined(EVENTLOG_SOCKET) +import GHC.Eventlog.Socket +#endif + +runWithStackProfiler :: IO () -> IO () +runWithStackProfiler act = +#if defined(SAMPLE_TRACER) + Profiler.withRootStackProfiler True $ \manager -> do + Profiler.withStackProfiler manager (Profiler.SampleIntervalMs 10) $ do + act +#else + act +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -105,6 +123,16 @@ import qualified Data.List.NonEmpty as NE main :: IO () main = do +#if defined(EVENTLOG_SOCKET) + hPutStrLn stderr "Instrumented" + eventlog_socket_env <- lookupEnv "GHC_EVENTLOG_SOCKET" + case eventlog_socket_env of + Just sock_path -> do + hPutStrLn stderr ("Starting eventlog socket on " ++ sock_path) + startWait sock_path + Nothing -> hPutStrLn stderr "Not starting socket as GHC_EVENTLOG_SOCKET is not set" + +#endif hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -152,7 +180,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 ===================================== @@ -22,11 +22,21 @@ Flag internal-interpreter Default: False Manual: True +Flag eventlog-socket + Description: Build with support for eventlog-socket + Default: False + Manual: True + Flag threaded Description: Link the ghc executable against the threaded RTS 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: GHC2024 @@ -45,6 +55,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 @@ -85,6 +99,10 @@ Executable ghc if flag(threaded) ghc-options: -threaded + if flag(eventlog-socket) + build-depends: eventlog-socket + CPP-OPTIONS: -DEVENTLOG_SOCKET + Other-Extensions: CPP NondecreasingIndentation ===================================== hadrian/src/Packages.hs ===================================== @@ -12,7 +12,9 @@ module Packages ( runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, timeout, transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, + eventlogSocket, eventlogSocketControl, ghcPackages, isGhcPackage, + async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -42,8 +44,11 @@ ghcPackages = , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell, thLift, thQuasiquoter , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout + , eventlogSocketControl, eventlogSocket , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -59,7 +64,8 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, transformers, unlit, unix, win32, xhtml, timeout, - lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, + eventlogSocket, eventlogSocketControl :: Package array = lib "array" base = lib "base" @@ -134,6 +140,13 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket" +eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control" +async = lib "async" +hashable = lib "hashable" +unorderedContainers = lib "unordered-containers" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Builders/Hsc2Hs.hs ===================================== @@ -23,7 +23,8 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do tmpl <- (top -/-) <$> expr (templateHscPath stage0Boot) mconcat [ arg $ "--cc=" ++ ccPath , arg $ "--ld=" ++ ccPath - , notM isWinTarget ? notM (flag CrossCompiling) ? arg "--cross-safe" + -- eventlog-socket uses directive not safe for cross compilation + -- , notM isWinTarget ? notM (flag CrossCompiling) ? arg "--cross-safe" , pure $ map ("-I" ++) (words gmpDir) , map ("--cflag=" ++) <$> getCFlags , map ("--lflag=" ++) <$> getLFlags ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -109,6 +109,8 @@ stage0Packages = do , thQuasiquoter -- new library not yet present for boot compilers , unlit , xhtml -- new version is not backwards compat with latest + , eventlogSocket + , eventlogSocketControl , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version -- bundled with GHC 9.6 is too old for `semaphore-compat`. @@ -182,6 +184,11 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_stack_profiler + , ghc_stack_profiler_core + , async + , hashable + , unorderedContainers ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -107,6 +107,22 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_stack_profiler ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + -- Add support for eventlog-socket commands + , arg "+control" + ] + ] + + , package eventlogSocket ? mconcat + [ builder (Cabal Flags) ? mconcat + [ + -- Add support for eventlog-socket commands + arg "+control" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat @@ -115,6 +131,8 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter" + , notStage0 `cabalFlag` "eventlog-socket" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. ===================================== libraries/async ===================================== @@ -0,0 +1 @@ +Subproject commit d5fdfb9117a983a3f07b213a8a4f8b1256a80f8c ===================================== libraries/hashable ===================================== @@ -0,0 +1 @@ +Subproject commit 535d33ef02bcabd06758f0ec6920ff9c02ef158f ===================================== libraries/unordered-containers ===================================== @@ -0,0 +1 @@ +Subproject commit 207901b4ded4799e41e0d4d45c3b198424ea4d17 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d2f9b80ed945fc38befbb9db355605... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d2f9b80ed945fc38befbb9db355605... You're receiving this email because of your account on gitlab.haskell.org.