Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • .gitmodules
    ... ... @@ -123,3 +123,18 @@
    123 123 
     [submodule "libraries/libffi-clib"]
    124 124 
     	path = libraries/libffi-clib
    125 125 
     	url = https://gitlab.haskell.org/ghc/libffi-clib.git
    126 
    +[submodule "eventlog-socket"]
    127 
    +	path = eventlog-socket
    128 
    +	url = https://github.com/well-typed/eventlog-socket.git
    129 
    +[submodule "ghc-stack-profiler"]
    130 
    +	path = ghc-stack-profiler
    131 
    +	url = https://github.com/well-typed/ghc-stack-profiler
    132 
    +[submodule "libraries/async"]
    133 
    +	path = libraries/async
    134 
    +	url = https://github.com/fendor/async.git
    135 
    +[submodule "libraries/unordered-containers"]
    136 
    +	path = libraries/unordered-containers
    137 
    +	url = https://github.com/fendor/unordered-containers.git
    138 
    +[submodule "libraries/hashable"]
    139 
    +	path = libraries/hashable
    140 
    +	url = https://github.com/fendor/hashable

  • eventlog-socket
    1 
    +Subproject commit 3fe3867e0d1c222be7a3868ef4bf65a717b7f151

  • ghc-stack-profiler
    1 
    +Subproject commit d8edeeef0b5f0babdcffc008f249a35e19cc0c8b

  • ghc/Main.hs
    ... ... @@ -79,6 +79,7 @@ import GHC.Iface.Errors.Ppr
    79 79 
     import GHC.Driver.Session.Mode
    80 80 
     import GHC.Driver.Session.Lint
    81 81 
     import GHC.Driver.Session.Units
    82 
    +import GHC.Driver.Monad
    82 83
    83 84 
     -- Standard Haskell libraries
    84 85 
     import System.IO
    ... ... @@ -90,6 +91,23 @@ import Control.Monad.Trans.Except (throwE, runExceptT)
    90 91 
     import Data.List ( isPrefixOf, partition, intercalate )
    91 92 
     import Prelude
    92 93 
     import qualified Data.List.NonEmpty as NE
    94 
    +#if defined(SAMPLE_TRACER)
    95 
    +import qualified GHC.Stack.Profiler.Sampler as Sampler
    96 
    +#endif
    97 
    +
    98 
    +#if defined(EVENTLOG_SOCKET)
    99 
    +import GHC.Eventlog.Socket
    100 
    +#endif
    101 
    +
    102 
    +runWithStackProfiler :: IO () -> IO ()
    103 
    +runWithStackProfiler act =
    104 
    +#if defined(SAMPLE_TRACER)
    105 
    +  setupRootStackProfiler True $ \manager -> do
    106 
    +    Sampler.withStackProfiler manager (Sampler.SampleIntervalMs 10) $ do
    107 
    +      act
    108 
    +#else
    109 
    +  act
    110 
    +#endif
    93 111
    94 112 
     -----------------------------------------------------------------------------
    95 113 
     -- ToDo:
    ... ... @@ -105,6 +123,16 @@ import qualified Data.List.NonEmpty as NE
    105 123
    106 124 
     main :: IO ()
    107 125 
     main = do
    126 
    +#if defined(EVENTLOG_SOCKET)
    127 
    +   hPutStrLn stderr "Instrumented"
    128 
    +   eventlog_socket_env <- lookupEnv "GHC_EVENTLOG_SOCKET"
    129 
    +   case eventlog_socket_env of
    130 
    +      Just sock_path -> do
    131 
    +        hPutStrLn stderr ("Starting eventlog socket on " ++ sock_path)
    132 
    +        startWait sock_path
    133 
    +      Nothing -> hPutStrLn stderr "Not starting socket as GHC_EVENTLOG_SOCKET is not set"
    134 
    +
    135 
    +#endif
    108 136 
        hSetBuffering stdout LineBuffering
    109 137 
        hSetBuffering stderr LineBuffering
    110 138
    ... ... @@ -152,7 +180,8 @@ main = do
    152 180 
                                 ShowGhciUsage          -> showGhciUsage dflags
    153 181 
                                 PrintWithDynFlags f    -> putStrLn (f dflags)
    154 182 
                     Right postLoadMode ->
    155 
    -                    main' postLoadMode units dflags argv3 flagWarnings
    183 
    +                  reifyGhc $ \session -> runWithStackProfiler $
    184 
    +                      reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
    156 185
    157 186 
     main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
    158 187 
           -> Ghc ()

  • ghc/ghc-bin.cabal.in
    ... ... @@ -22,11 +22,21 @@ Flag internal-interpreter
    22 22 
         Default: False
    23 23 
         Manual: True
    24 24
    25 
    +Flag eventlog-socket
    26 
    +    Description: Build with support for eventlog-socket
    27 
    +    Default: False
    28 
    +    Manual: True
    29 
    +
    25 30 
     Flag threaded
    26 31 
         Description: Link the ghc executable against the threaded RTS
    27 32 
         Default: True
    28 33 
         Manual: True
    29 34
    35 
    +Flag sampleTracer
    36 
    +    Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled
    37 
    +    Default: False
    38 
    +    Manual: True
    39 
    +
    30 40 
     Executable ghc
    31 41 
         Default-Language: GHC2024
    32 42
    ... ... @@ -45,6 +55,10 @@ Executable ghc
    45 55 
                        ghc-boot      == @ProjectVersionMunged@,
    46 56 
                        ghc           == @ProjectVersionMunged@
    47 57
    58 
    +    if flag(sampleTracer)
    59 
    +        build-depends: ghc-stack-profiler
    60 
    +        CPP-OPTIONS: -DSAMPLE_TRACER
    61 
    +
    48 62 
         if os(windows)
    49 63 
             Build-Depends: Win32  >= 2.3 && < 2.15
    50 64 
         else
    ... ... @@ -85,6 +99,10 @@ Executable ghc
    85 99 
         if flag(threaded)
    86 100 
           ghc-options: -threaded
    87 101
    102 
    +    if flag(eventlog-socket)
    103 
    +      build-depends: eventlog-socket
    104 
    +      CPP-OPTIONS: -DEVENTLOG_SOCKET
    105 
    +
    88 106 
         Other-Extensions:
    89 107 
             CPP
    90 108 
             NondecreasingIndentation

  • hadrian/src/Packages.hs
    ... ... @@ -12,7 +12,9 @@ module Packages (
    12 12 
         runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, timeout,
    13 13 
         transformers, unlit, unix, win32, xhtml,
    14 14 
         lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
    15 
    +    eventlogSocket, eventlogSocketControl,
    15 16 
         ghcPackages, isGhcPackage,
    17 
    +    async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core,
    16 18
    17 19 
         -- * Package information
    18 20 
         crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath,
    ... ... @@ -42,8 +44,11 @@ ghcPackages =
    42 44 
         , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell, thLift, thQuasiquoter
    43 45 
         , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio
    44 46 
         , timeout
    47 
    +    , eventlogSocketControl, eventlogSocket
    45 48 
         , lintersCommon
    46 
    -    , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
    49 
    +    , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
    50 
    +    , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler
    51 
    +    ]
    47 52
    48 53 
     -- TODO: Optimise by switching to sets of packages.
    49 54 
     isGhcPackage :: Package -> Bool
    ... ... @@ -59,7 +64,8 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
    59 64 
       osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter,
    60 65 
       terminfo, text, time, transformers, unlit, unix, win32, xhtml,
    61 66 
       timeout,
    62 
    -  lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
    67 
    +  lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
    68 
    +  eventlogSocket, eventlogSocketControl
    63 69 
         :: Package
    64 70 
     array               = lib  "array"
    65 71 
     base                = lib  "base"
    ... ... @@ -134,6 +140,13 @@ unlit = util "unlit"
    134 140 
     unix                = lib  "unix"
    135 141 
     win32               = lib  "Win32"
    136 142 
     xhtml               = lib  "xhtml"
    143 
    +eventlogSocket      = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket"
    144 
    +eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control"
    145 
    +async               = lib "async"
    146 
    +hashable            = lib "hashable"
    147 
    +unorderedContainers = lib "unordered-containers"
    148 
    +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler"
    149 
    +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core"
    137 150
    138 151 
     lintersCommon       = lib     "linters-common"      `setPath` "linters/linters-common"
    139 152 
     lintNotes           = linter  "lint-notes"

  • hadrian/src/Settings/Builders/Hsc2Hs.hs
    ... ... @@ -23,7 +23,8 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
    23 23 
         tmpl <- (top -/-) <$> expr (templateHscPath stage0Boot)
    24 24 
         mconcat [ arg $ "--cc=" ++ ccPath
    25 25 
                 , arg $ "--ld=" ++ ccPath
    26 
    -            , notM isWinTarget ? notM (flag CrossCompiling) ? arg "--cross-safe"
    26 
    +            -- eventlog-socket uses directive not safe for cross compilation
    27 
    +            -- , notM isWinTarget ? notM (flag CrossCompiling) ? arg "--cross-safe"
    27 28 
                 , pure $ map ("-I" ++) (words gmpDir)
    28 29 
                 , map ("--cflag=" ++) <$> getCFlags
    29 30 
                 , map ("--lflag=" ++) <$> getLFlags

  • hadrian/src/Settings/Default.hs
    ... ... @@ -109,6 +109,8 @@ stage0Packages = do
    109 109 
                  , thQuasiquoter -- new library not yet present for boot compilers
    110 110 
                  , unlit
    111 111 
                  , xhtml -- new version is not backwards compat with latest
    112 
    +             , eventlogSocket
    113 
    +             , eventlogSocketControl
    112 114 
                  , if windowsHost then win32 else unix
    113 115 
                  -- We must use the in-tree `Win32` as the version
    114 116 
                  -- bundled with GHC 9.6 is too old for `semaphore-compat`.
    ... ... @@ -182,6 +184,11 @@ stage1Packages = do
    182 184 
             , unlit
    183 185 
             , xhtml
    184 186 
             , if winTarget then win32 else unix
    187 
    +        , ghc_stack_profiler
    188 
    +        , ghc_stack_profiler_core
    189 
    +        , async
    190 
    +        , hashable
    191 
    +        , unorderedContainers
    185 192 
             ]
    186 193 
           , when (not cross)
    187 194 
             [ hpcBin

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -107,6 +107,22 @@ packageArgs = do
    107 107
    108 108 
               , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ]
    109 109
    110 
    +        , package ghc_stack_profiler ? mconcat
    111 
    +          [ builder (Cabal Flags) ? mconcat
    112 
    +            [ arg "-use-ghc-trace-events"
    113 
    +            -- Add support for eventlog-socket commands
    114 
    +            , arg "+control"
    115 
    +            ]
    116 
    +          ]
    117 
    +
    118 
    +        , package eventlogSocket ? mconcat
    119 
    +          [ builder (Cabal Flags) ? mconcat
    120 
    +            [
    121 
    +            -- Add support for eventlog-socket commands
    122 
    +              arg "+control"
    123 
    +            ]
    124 
    +          ]
    125 
    +
    110 126 
             ---------------------------------- ghc ---------------------------------
    111 127 
             , package ghc ? mconcat
    112 128 
               [ builder Ghc ? mconcat
    ... ... @@ -115,6 +131,8 @@ packageArgs = do
    115 131
    116 132 
               , builder (Cabal Flags) ? mconcat
    117 133 
                 [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter"
    134 
    +            , notStage0 `cabalFlag` "eventlog-socket"
    135 
    +            , notStage0 `cabalFlag` "sampleTracer"
    118 136 
                 , ifM stage0
    119 137 
                       -- We build a threaded stage 1 if the bootstrapping compiler
    120 138 
                       -- supports it.

  • libraries/async
    1 
    +Subproject commit d5fdfb9117a983a3f07b213a8a4f8b1256a80f8c

  • libraries/hashable
    1 
    +Subproject commit 535d33ef02bcabd06758f0ec6920ff9c02ef158f

  • libraries/unordered-containers
    1 
    +Subproject commit 207901b4ded4799e41e0d4d45c3b198424ea4d17

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help