Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • .gitmodules
    ... ... @@ -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

  • eventlog-live-profiling-prototype
    1 
    +Subproject commit 4ebbfbfffd3dd255a661414b5d7c9a990ff4f4fc

  • ghc/Main.hs
    ... ... @@ -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 Sampler
    97 
    +#endif
    98 
    +
    99 
    +runWithSampleProfiler :: IO () -> IO ()
    100 
    +runWithSampleProfiler =
    101 
    +#if defined(SAMPLE_TRACER)
    102 
    +  withSampleProfiler 10000 {- Every 10 ms -}
    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 -> runWithSampleProfiler $
    169 
    +                      reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
    157 170
    158 171 
     main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
    159 172 
           -> Ghc ()

  • ghc/ghc-bin.cabal.in
    ... ... @@ -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-sampler-eventlog
    55 
    +        CPP-OPTIONS: -DSAMPLE_TRACER
    56 
    +
    48 57 
         if os(windows)
    49 58 
             Build-Depends: Win32  >= 2.3 && < 2.15
    50 59 
         else

  • hadrian/src/Packages.hs
    ... ... @@ -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_sampler_eventlog,
    16 17
    17 18 
         -- * Package information
    18 19 
         crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath,
    ... ... @@ -43,7 +44,8 @@ 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_sampler_eventlog
    48 
    +    ]
    47 49
    48 50 
     -- TODO: Optimise by switching to sets of packages.
    49 51 
     isGhcPackage :: Package -> Bool
    ... ... @@ -135,6 +137,7 @@ unlit = util "unlit"
    135 137 
     unix                = lib  "unix"
    136 138 
     win32               = lib  "Win32"
    137 139 
     xhtml               = lib  "xhtml"
    140 
    +ghc_sampler_eventlog = lib "ghc-sampler-eventlog" `setPath` "eventlog-live-profiling-prototype/sampler"
    138 141
    139 142 
     lintersCommon       = lib     "linters-common"      `setPath` "linters/linters-common"
    140 143 
     lintNotes           = linter  "lint-notes"

  • hadrian/src/Settings/Default.hs
    ... ... @@ -180,6 +180,7 @@ stage1Packages = do
    180 180 
             , unlit
    181 181 
             , xhtml
    182 182 
             , if winTarget then win32 else unix
    183 
    +        , ghc_sampler_eventlog
    183 184 
             ]
    184 185 
           , when (not cross)
    185 186 
             [ hpcBin

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -108,6 +108,12 @@ packageArgs = do
    108 108
    109 109 
               , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ]
    110 110
    111 
    +        , package ghc_sampler_eventlog ? 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

  • libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc
    ... ... @@ -15,12 +15,13 @@ module GHC.Internal.InfoProv.Types
    15 15 
         , getIPE
    16 16 
         , StgInfoTable
    17 17 
         , lookupIPE
    18 
    +    , lookupIpProvId
    18 19 
         ) where
    19 20
    20 21 
     import GHC.Internal.Base
    21 22 
     import GHC.Internal.Enum
    22 23 
     import GHC.Internal.Real (fromIntegral)
    23 
    -import GHC.Internal.Word (Word32)
    24 
    +import GHC.Internal.Word (Word32, Word64)
    24 25 
     import GHC.Internal.Show (Show)
    25 26 
     import GHC.Internal.Ptr (Ptr(..), plusPtr)
    26 27 
     import GHC.Internal.Foreign.C.String.Encoding (CString, peekCString)
    ... ... @@ -32,6 +33,7 @@ import GHC.Internal.ClosureTypes
    32 33 
     import GHC.Internal.Prim (whereFrom##)
    33 34
    34 35 
     data InfoProv = InfoProv {
    36 
    +  ipProvId :: Word64,
    35 37 
       ipName :: String,
    36 38 
       ipDesc :: ClosureType,
    37 39 
       ipTyDesc :: String,
    ... ... @@ -59,6 +61,13 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do
    59 61 
         1 -> Just `fmap` peekInfoProv (ipeProv p)
    60 62 
         _ -> return Nothing
    61 63
    64 
    +lookupIpProvId :: Ptr StgInfoTable -> IO (Maybe Word64)
    65 
    +lookupIpProvId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do
    66 
    +  res <- c_lookupIPE itbl p
    67 
    +  case res of
    68 
    +    1 -> Just `fmap` peekIpProvId (ipeProv p)
    69 
    +    _ -> return Nothing
    70 
    +
    62 71 
     getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r
    63 72 
     getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s ->
    64 73 
       case whereFrom## obj (unPtr p) s of
    ... ... @@ -73,6 +82,9 @@ ipeProv p = (#ptr InfoProvEnt, prov) p
    73 82 
     peekIpDesc :: Ptr InfoProv -> IO Word32
    74 83 
     peekIpDesc p    =  (# peek InfoProv, closure_desc) p
    75 84
    85 
    +peekIpProvId :: Ptr InfoProv -> IO Word64
    86 
    +peekIpProvId p  =  (# peek InfoProv, info_prov_id) p
    87 
    +
    76 88 
     peekIpName, peekIpLabel, peekIpUnitId, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString
    77 89 
     peekIpName p    =  (# peek InfoProv, table_name) p
    78 90 
     peekIpLabel p   =  (# peek InfoProv, label) p
    ... ... @@ -84,6 +96,7 @@ peekIpTyDesc p = (# peek InfoProv, ty_desc) p
    84 96
    85 97 
     peekInfoProv :: Ptr InfoProv -> IO InfoProv
    86 98 
     peekInfoProv infop = do
    99 
    +  provId <- peekIpProvId infop
    87 100 
       name <- peekCString utf8 =<< peekIpName infop
    88 101 
       desc <- peekIpDesc infop
    89 102 
       tyDesc <- peekCString utf8 =<< peekIpTyDesc infop
    ... ... @@ -93,6 +106,7 @@ peekInfoProv infop = do
    93 106 
       file <- peekCString utf8 =<< peekIpSrcFile infop
    94 107 
       span <- peekCString utf8 =<< peekIpSrcSpan infop
    95 108 
       return InfoProv {
    109 
    +      ipProvId = provId,
    96 110 
           ipName = name,
    97 111 
           -- The INVALID_OBJECT case should be impossible as we
    98 112 
           -- control the C code generating these values.

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    ... ... @@ -25,6 +25,10 @@ module GHC.Internal.Stack.Decode (
    25 25 
       -- * Pretty printing
    26 26 
       prettyStackEntry,
    27 27 
       prettyStackFrameWithIpe,
    28 
    +  -- * Low level decoding functions
    29 
    +  StackFrameLocation(..),
    30 
    +  unpackStackFrameTo,
    31 
    +  getStackFields,
    28 32 
       )
    29 33 
     where
    30 34
    ... ... @@ -69,6 +73,7 @@ import GHC.Internal.Stack.ConstantsProf ()
    69 73 
     #endif
    70 74 
     import GHC.Internal.Stack.CloneStack
    71 75 
     import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
    76 
    +import qualified GHC.Internal.InfoProv.Types as IPE
    72 77
    73 78 
     {- Note [Decoding the stack]
    74 79 
        ~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -186,11 +191,11 @@ foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSna
    186 191
    187 192 
     -- | Get the 'StgInfoTable' of the stack frame.
    188 193 
     -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
    189 
    -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
    194 
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Ptr IPE.StgInfoTable)
    190 195 
     getInfoTableOnStack stackSnapshot# index =
    191 196 
       let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
    192 197 
        in
    193 
    -    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
    198 
    +    (,) <$> peekItbl (Ptr itbl_struct#) <*> pure (Ptr itbl_ptr_ipe_key#)
    194 199
    195 200 
     getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    196 201 
     getInfoTableForStack stackSnapshot# =
    ... ... @@ -324,8 +329,9 @@ unpackStackFrame stackFrameLoc = do
    324 329 
     unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
    325 330 
     unpackStackFrameWithIpe stackFrameLoc = do
    326 331 
       unpackStackFrameTo stackFrameLoc
    327 
    -    (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
    332 
    +    (\ info infoKey nextChunk@(StackSnapshot stack#) -> do
    328 333 
           framesWithIpe <- decodeStackWithIpe nextChunk
    334 
    +      mIpe <- lookupIPE infoKey
    329 335 
           pure
    330 336 
             [ ( UnderflowFrame
    331 337 
                 { info_tbl = info,
    ... ... @@ -340,22 +346,26 @@ unpackStackFrameWithIpe stackFrameLoc = do
    340 346 
               )
    341 347 
             ]
    342 348 
         )
    343 
    -    (\ frame mIpe -> pure [(frame, mIpe)])
    349 
    +    (\ frame infoKey -> do
    350 
    +      mIpe <- lookupIPE infoKey
    351 
    +      pure [(frame, mIpe)])
    344 352
    345 353 
     unpackStackFrameTo ::
    346 354 
       forall a .
    347 355 
       StackFrameLocation ->
    348 356 
       -- ^ Decode the given 'StackFrame'.
    349 
    -  (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
    357 
    +  (StgInfoTable -> Ptr IPE.StgInfoTable -> StackSnapshot -> IO a) ->
    350 358 
       -- ^ How to handle 'UNDERFLOW_FRAME's.
    351 
    -  (StackFrame -> Maybe InfoProv -> IO a) ->
    359 
    +  -- The pointer is the key for the 'lookupIPE'.
    360 
    +  (StackFrame -> Ptr IPE.StgInfoTable -> IO a) ->
    352 361 
       -- ^ How to handle all other 'StackFrame' values.
    362 
    +  -- The pointer is the key for the 'lookupIPE'.
    353 363 
       IO a
    354 364 
     unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
    355 
    -  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    365 
    +  (info, infoTablePtr) <- getInfoTableOnStack stackSnapshot# index
    356 366 
       unpackStackFrame' info
    357 
    -    (unpackUnderflowFrame info m_info_prov)
    358 
    -    (`finaliseStackFrame` m_info_prov)
    367 
    +    (unpackUnderflowFrame info infoTablePtr)
    368 
    +    (`finaliseStackFrame` infoTablePtr)
    359 369 
       where
    360 370 
         unpackStackFrame' ::
    361 371 
           StgInfoTable ->

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -545,7 +545,11 @@ instance Binary Heap.ClosureType
    545 545 
     instance Binary Heap.PrimType
    546 546 
     instance Binary a => Binary (Heap.GenClosure a)
    547 547 
     instance Binary InfoProv where
    548 
    -#if MIN_VERSION_base(4,20,0)
    548 
    +#if MIN_VERSION_base(4,22,0)
    549 
    +  get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
    550 
    +  put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8 x9)
    551 
    +    = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 >> put x9
    552 
    +#elif MIN_VERSION_base(4,20,0)
    549 553 
       get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
    550 554 
       put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8)
    551 555 
         = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8

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