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

Commits:

10 changed files:

Changes:

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

  • ghc-stack-profiler
    1
    +Subproject commit 389d886a1494cd019ee93c72c8f19cf7f9dc1664

  • ghc/Main.hs
    ... ... @@ -81,6 +81,7 @@ import GHC.Iface.Errors.Ppr
    81 81
     import GHC.Driver.Session.Mode
    
    82 82
     import GHC.Driver.Session.Lint
    
    83 83
     import GHC.Driver.Session.Units
    
    84
    +import GHC.Driver.Monad
    
    84 85
     
    
    85 86
     -- Standard Haskell libraries
    
    86 87
     import System.IO
    
    ... ... @@ -92,11 +93,23 @@ import Control.Monad.Trans.Except (throwE, runExceptT)
    92 93
     import Data.List ( isPrefixOf, partition, intercalate )
    
    93 94
     import Prelude
    
    94 95
     import qualified Data.List.NonEmpty as NE
    
    96
    +#if defined(SAMPLE_TRACER)
    
    97
    +import qualified GHC.Stack.Profiler as Profiler
    
    98
    +#endif
    
    95 99
     
    
    96 100
     #if defined(EVENTLOG_SOCKET)
    
    97 101
     import GHC.Eventlog.Socket
    
    98 102
     #endif
    
    99 103
     
    
    104
    +runWithStackProfiler :: IO () -> IO ()
    
    105
    +runWithStackProfiler act =
    
    106
    +#if defined(SAMPLE_TRACER)
    
    107
    +  Profiler.withProfiler
    
    108
    +      act
    
    109
    +#else
    
    110
    +  act
    
    111
    +#endif
    
    112
    +
    
    100 113
     -----------------------------------------------------------------------------
    
    101 114
     -- ToDo:
    
    102 115
     
    
    ... ... @@ -168,7 +181,8 @@ main = do
    168 181
                                 ShowGhciUsage          -> showGhciUsage dflags
    
    169 182
                                 PrintWithDynFlags f    -> putStrLn (f dflags)
    
    170 183
                     Right postLoadMode ->
    
    171
    -                    main' postLoadMode units dflags argv3 flagWarnings
    
    184
    +                  reifyGhc $ \session -> runWithStackProfiler $
    
    185
    +                      reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
    
    172 186
     
    
    173 187
     main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
    
    174 188
           -> Ghc ()
    

  • ghc/ghc-bin.cabal.in
    ... ... @@ -37,6 +37,11 @@ Flag threaded
    37 37
         Default: True
    
    38 38
         Manual: True
    
    39 39
     
    
    40
    +Flag sampleTracer
    
    41
    +    Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled
    
    42
    +    Default: False
    
    43
    +    Manual: True
    
    44
    +
    
    40 45
     Executable ghc
    
    41 46
         Default-Language: GHC2024
    
    42 47
     
    
    ... ... @@ -55,6 +60,10 @@ Executable ghc
    55 60
                        ghc-boot      == @ProjectVersionMunged@,
    
    56 61
                        ghc           == @ProjectVersionMunged@
    
    57 62
     
    
    63
    +    if flag(sampleTracer)
    
    64
    +        build-depends: ghc-stack-profiler
    
    65
    +        CPP-OPTIONS: -DSAMPLE_TRACER
    
    66
    +
    
    58 67
         if os(windows)
    
    59 68
             Build-Depends: Win32  >= 2.3 && < 2.15
    
    60 69
         else
    

  • hadrian/src/Packages.hs
    ... ... @@ -14,6 +14,7 @@ module Packages (
    14 14
         lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
    
    15 15
         eventlogSocket, eventlogSocketControl,
    
    16 16
         ghcPackages, isGhcPackage,
    
    17
    +    async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core,
    
    17 18
     
    
    18 19
         -- * Package information
    
    19 20
         crossPrefix, programBasename, programName, nonHsMainPackage, programPath, timeoutPath,
    
    ... ... @@ -44,7 +45,9 @@ ghcPackages =
    44 45
         , timeout
    
    45 46
         , eventlogSocketControl, eventlogSocket
    
    46 47
         , lintersCommon
    
    47
    -    , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
    
    48
    +    , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
    
    49
    +    , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler
    
    50
    +    ]
    
    48 51
     
    
    49 52
     -- TODO: Optimise by switching to sets of packages.
    
    50 53
     isGhcPackage :: Package -> Bool
    
    ... ... @@ -139,6 +142,11 @@ win32 = lib "Win32"
    139 142
     xhtml               = lib  "xhtml"
    
    140 143
     eventlogSocket      = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket"
    
    141 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"
    
    142 150
     
    
    143 151
     lintersCommon       = lib     "linters-common"      `setPath` "linters/linters-common"
    
    144 152
     lintNotes           = linter  "lint-notes"
    

  • hadrian/src/Settings/Default.hs
    ... ... @@ -192,6 +192,11 @@ stagedPackages stage = do
    192 192
             , hpcBin
    
    193 193
             , if winTarget then win32 else unix
    
    194 194
             , runGhc
    
    195
    +        , ghc_stack_profiler
    
    196
    +        , ghc_stack_profiler_core
    
    197
    +        , async
    
    198
    +        , hashable
    
    199
    +        , unorderedContainers
    
    195 200
             ]
    
    196 201
           , when (winTarget && not cross)
    
    197 202
             [ -- See Note [Hadrian's ghci-wrapper package]
    

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

  • libraries/async
    1
    +Subproject commit 474fc7f612b74e73e24e91474fa75af18eede7b7

  • libraries/hashable
    1
    +Subproject commit d56d62eb2a9ff4376e7119d925ececa60959d9ec

  • libraries/unordered-containers
    1
    +Subproject commit 368ea40488bf3c644e9c36d996302029fb0fc227