Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC

Commits:

20 changed files:

Changes:

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -110,8 +110,9 @@ assembleBCOs
    110 110
       -> [(Name, ByteString)]
    
    111 111
       -> Maybe InternalModBreaks
    
    112 112
       -> [SptEntry]
    
    113
    +  -> Maybe ByteCodeHpcInfo
    
    113 114
       -> IO CompiledByteCode
    
    114
    -assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
    
    115
    +assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries use_hpc = do
    
    115 116
       -- TODO: the profile should be bundled with the interpreter: the rts ways are
    
    116 117
       -- fixed for an interpreter
    
    117 118
       let itbls = mkITbls profile tycons
    
    ... ... @@ -122,6 +123,7 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
    122 123
         , bc_strs = top_strs
    
    123 124
         , bc_breaks = modbreaks
    
    124 125
         , bc_spt_entries = spt_entries
    
    126
    +    , bc_hpc_info = use_hpc
    
    125 127
         }
    
    126 128
     
    
    127 129
     -- Note [Allocating string literals]
    

  • compiler/GHC/ByteCode/Serialize.hs
    ... ... @@ -112,7 +112,7 @@ type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)
    112 112
     -- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
    
    113 113
     data BytecodeLibX a = BytecodeLib {
    
    114 114
         bytecodeLibUnitId :: UnitId,
    
    115
    -    bytecodeLibFiles :: [CompiledByteCode],
    
    115
    +    bytecodeLibFiles :: [(Module, CompiledByteCode)],
    
    116 116
         bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
    
    117 117
     }
    
    118 118
     
    
    ... ... @@ -295,13 +295,15 @@ instance Binary CompiledByteCode where
    295 295
           replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
    
    296 296
         bc_breaks <- get bh
    
    297 297
         bc_spt_entries <- get bh
    
    298
    +    bc_hpc_info <- get bh
    
    298 299
         return $
    
    299 300
           CompiledByteCode
    
    300 301
             { bc_bcos,
    
    301 302
               bc_itbls,
    
    302 303
               bc_strs,
    
    303 304
               bc_breaks,
    
    304
    -          bc_spt_entries
    
    305
    +          bc_spt_entries,
    
    306
    +          bc_hpc_info
    
    305 307
             }
    
    306 308
     
    
    307 309
       put_ bh CompiledByteCode {..} = do
    
    ... ... @@ -314,6 +316,23 @@ instance Binary CompiledByteCode where
    314 316
         for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
    
    315 317
         put_ bh bc_breaks
    
    316 318
         put_ bh bc_spt_entries
    
    319
    +    put_ bh bc_hpc_info
    
    320
    +
    
    321
    +instance Binary ByteCodeHpcInfo where
    
    322
    +  put_ bh ByteCodeHpcInfo{bchi_tick_count,bchi_hash,bchi_tickboxes} = do
    
    323
    +    put_ bh bchi_tick_count
    
    324
    +    put_ bh bchi_hash
    
    325
    +    put_ bh bchi_tickboxes
    
    326
    +
    
    327
    +  get bh = do
    
    328
    +    bchi_tick_count <- get bh
    
    329
    +    bchi_hash <- get bh
    
    330
    +    bchi_tickboxes <- get bh
    
    331
    +    pure ByteCodeHpcInfo
    
    332
    +      { bchi_tick_count
    
    333
    +      , bchi_hash
    
    334
    +      , bchi_tickboxes
    
    335
    +      }
    
    317 336
     
    
    318 337
     instance Binary UnlinkedBCO where
    
    319 338
       get bh =
    

  • compiler/GHC/ByteCode/Types.hs
    ... ... @@ -22,6 +22,9 @@ module GHC.ByteCode.Types
    22 22
       -- * Mod Breaks
    
    23 23
       , ModBreaks (..), BreakpointId(..), BreakTickIndex
    
    24 24
     
    
    25
    +  -- * Hpc Info
    
    26
    +  , ByteCodeHpcInfo(..)
    
    27
    +
    
    25 28
       -- * Internal Mod Breaks
    
    26 29
       , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks
    
    27 30
       -- ** Internal breakpoint identifier
    
    ... ... @@ -76,6 +79,13 @@ data CompiledByteCode = CompiledByteCode
    76 79
         -- ^ Static pointer table entries which should be loaded along with the
    
    77 80
         -- BCOs. See Note [Grand plan for static forms] in
    
    78 81
         -- "GHC.Iface.Tidy.StaticPtrTable".
    
    82
    +  , bc_hpc_info :: Maybe ByteCodeHpcInfo -- ^ TODO: @fendor
    
    83
    +  }
    
    84
    +
    
    85
    +data ByteCodeHpcInfo = ByteCodeHpcInfo
    
    86
    +  { bchi_tick_count :: {-# UNPACK #-} !Int
    
    87
    +  , bchi_hash :: {-# UNPACK #-} !Int
    
    88
    +  , bchi_tickboxes :: !ByteString
    
    79 89
       }
    
    80 90
     
    
    81 91
     -- | A libffi ffi_cif function prototype.
    

  • compiler/GHC/Driver/CodeOutput.hs
    ... ... @@ -278,13 +278,12 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
    278 278
     
    
    279 279
          ForeignStubs (CHeader h_code) cstub -> do
    
    280 280
             let
    
    281
    -            stub_c_output_d = pprCode (getCStub cstub $$ pprCStubInitFiniDecls platform cstub)
    
    281
    +            stub_c_output_d = pprCode (getCStub cstub)
    
    282 282
                 stub_c_output_w = showSDoc dflags stub_c_output_d
    
    283 283
     
    
    284 284
                 -- Header file protos for "foreign export"ed functions.
    
    285 285
                 stub_h_output_d = pprCode h_code
    
    286 286
                 stub_h_output_w = showSDoc dflags stub_h_output_d
    
    287
    -            platform = targetPlatform dflags
    
    288 287
     
    
    289 288
             putDumpFileMaybe logger Opt_D_dump_foreign
    
    290 289
                           "Foreign export header file"
    
    ... ... @@ -344,29 +343,6 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
    344 343
        cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
    
    345 344
        cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
    
    346 345
     
    
    347
    -pprCStubInitFiniDecls :: Platform -> CStub -> SDoc
    
    348
    -pprCStubInitFiniDecls platform cstub =
    
    349
    -  vcat (zipWith (pprInitOrFiniDecl "ini" ".init_array") [0 :: Int ..] (getInitializers cstub))
    
    350
    -  $$ vcat (zipWith (pprInitOrFiniDecl "fini" ".fini_array") [0 :: Int ..] (getFinalizers cstub))
    
    351
    -  where
    
    352
    -    pprInitOrFiniDecl :: String -> String -> Int -> CLabel -> SDoc
    
    353
    -    pprInitOrFiniDecl suf section_name n lbl =
    
    354
    -      vcat
    
    355
    -        [ hsep [text "extern void", pprCLabel platform lbl, text "(void);"]
    
    356
    -        , hsep [ text "static void (*"
    
    357
    -               <> text "__ghc_" <> text suf <> text "_"
    
    358
    -               <> int n
    
    359
    -               <> text ")(void)"
    
    360
    -               , text "__attribute__((used, section("
    
    361
    -                 <> doubleQuotes (text section_name)
    
    362
    -                 <> text ")))"
    
    363
    -               , equals
    
    364
    -               , pprCLabel platform lbl
    
    365
    -               <> semi
    
    366
    -               ]
    
    367
    -        ]
    
    368
    -
    
    369
    -
    
    370 346
     -- It is more than likely that the stubs file will
    
    371 347
     -- turn out to be empty, in which case no file should be created.
    
    372 348
     outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
    

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -151,6 +151,7 @@ import GHC.Hs.Dump
    151 151
     import GHC.Hs.Stats         ( ppSourceStats )
    
    152 152
     
    
    153 153
     import GHC.HsToCore
    
    154
    +import GHC.HsToCore.Coverage ( hpcTickBoxes )
    
    154 155
     
    
    155 156
     import GHC.StgToByteCode    ( byteCodeGen )
    
    156 157
     import GHC.StgToJS          ( stgToJS )
    
    ... ... @@ -237,6 +238,7 @@ import GHC.Types.Var.Set
    237 238
     import GHC.Types.Error
    
    238 239
     import GHC.Types.Fixity.Env
    
    239 240
     import GHC.Types.CostCentre
    
    241
    +import GHC.Types.HpcInfo (HpcInfo (..))
    
    240 242
     import GHC.Types.IPE
    
    241 243
     import GHC.Types.SourceFile
    
    242 244
     import GHC.Types.SrcLoc
    
    ... ... @@ -299,6 +301,8 @@ import qualified GHC.Unit.Home.Graph as HUG
    299 301
     import GHC.Unit.Home.PackageTable
    
    300 302
     
    
    301 303
     import GHC.ByteCode.Serialize
    
    304
    +import GHC.Driver.Ppr (showSDoc)
    
    305
    +import qualified Data.ByteString.Char8 as BS8
    
    302 306
     
    
    303 307
     {- **********************************************************************
    
    304 308
     %*                                                                      *
    
    ... ... @@ -1186,7 +1190,7 @@ compileWholeCoreBindings hsc_env type_env wcb = do
    1186 1190
         gen_bytecode core_binds stubs foreign_files = do
    
    1187 1191
           let cgi_guts = CgInteractiveGuts wcb_module core_binds
    
    1188 1192
                           (typeEnvTyCons type_env) stubs foreign_files
    
    1189
    -                      Nothing []
    
    1193
    +                      Nothing [] NoHpcInfo
    
    1190 1194
           trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module)
    
    1191 1195
           mkModuleByteCode hsc_env wcb_module wcb_mod_location cgi_guts
    
    1192 1196
     
    
    ... ... @@ -2136,11 +2140,12 @@ data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module
    2136 2140
                                                , cgi_foreign_files :: [(ForeignSrcLang, FilePath)]
    
    2137 2141
                                                , cgi_modBreaks ::  Maybe ModBreaks
    
    2138 2142
                                                , cgi_spt_entries :: [SptEntry]
    
    2143
    +                                           , cgi_hpc_info :: HpcInfo
    
    2139 2144
                                                }
    
    2140 2145
     
    
    2141 2146
     mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
    
    2142
    -mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries}
    
    2143
    -  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries
    
    2147
    +mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries, cg_hpc_info}
    
    2148
    +  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries cg_hpc_info
    
    2144 2149
     
    
    2145 2150
     hscInteractive :: HscEnv
    
    2146 2151
                    -> CgInteractiveGuts
    
    ... ... @@ -2163,13 +2168,15 @@ hscGenerateByteCode :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Compiled
    2163 2168
     hscGenerateByteCode hsc_env cgguts location = do
    
    2164 2169
         let dflags = hsc_dflags hsc_env
    
    2165 2170
         let logger = hsc_logger hsc_env
    
    2171
    +    let platform = targetPlatform dflags
    
    2166 2172
         let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation.
    
    2167 2173
                     -- From now on, we just use the bits we need.
    
    2168 2174
                    cgi_module   = this_mod,
    
    2169 2175
                    cgi_binds    = core_binds,
    
    2170 2176
                    cgi_tycons   = tycons,
    
    2171 2177
                    cgi_modBreaks = mod_breaks,
    
    2172
    -               cgi_spt_entries = spt_entries } = cgguts
    
    2178
    +               cgi_spt_entries = spt_entries,
    
    2179
    +               cgi_hpc_info = hpc_info } = cgguts
    
    2173 2180
     
    
    2174 2181
         -------------------
    
    2175 2182
         -- ADD IMPLICIT BINDINGS
    
    ... ... @@ -2194,8 +2201,20 @@ hscGenerateByteCode hsc_env cgguts location = do
    2194 2201
     
    
    2195 2202
         let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
    
    2196 2203
     
    
    2204
    +    -------------------
    
    2205
    +    -- Setup HPC info
    
    2206
    +    let
    
    2207
    +      bytecodeHpcInfo = case hpc_info of
    
    2208
    +        NoHpcInfo -> Nothing
    
    2209
    +        HpcInfo{hpcInfoTickCount, hpcInfoHash} ->
    
    2210
    +          Just ByteCodeHpcInfo
    
    2211
    +            { bchi_tick_count = hpcInfoTickCount
    
    2212
    +            , bchi_hash = hpcInfoHash
    
    2213
    +            , bchi_tickboxes = BS8.pack . (++ "\0") . showSDoc dflags $ hpcTickBoxes platform this_mod
    
    2214
    +            }
    
    2215
    +
    
    2197 2216
         -----------------  Generate byte code ------------------
    
    2198
    -    byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries
    
    2217
    +    byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries bytecodeHpcInfo
    
    2199 2218
     
    
    2200 2219
     -- | Generate a byte code object linkable and write it to a file if `-fwrite-byte-code` is enabled.
    
    2201 2220
     generateAndWriteByteCode :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO ModuleByteCode
    
    ... ... @@ -2844,6 +2863,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
    2844 2863
                     []
    
    2845 2864
                     Nothing -- modbreaks
    
    2846 2865
                     [] -- spt entries
    
    2866
    +                Nothing -- no hpc info
    
    2847 2867
     
    
    2848 2868
           {- load it -}
    
    2849 2869
           bco_time <- getCurrentTime
    

  • compiler/GHC/HsToCore/Coverage.hs
    ... ... @@ -6,6 +6,9 @@
    6 6
     module GHC.HsToCore.Coverage
    
    7 7
       ( writeMixEntries
    
    8 8
       , hpcInitCode
    
    9
    +  , hpcStubLabel
    
    10
    +  , hpcModuleName
    
    11
    +  , hpcTickBoxes
    
    9 12
       ) where
    
    10 13
     
    
    11 14
     import GHC.Prelude as Prelude
    
    ... ... @@ -116,24 +119,33 @@ hpcInitCode _ _ (NoHpcInfo {}) = mempty
    116 119
     hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
    
    117 120
      = initializerCStub platform fn_name decls body
    
    118 121
       where
    
    119
    -    fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")
    
    122
    +    fn_name = hpcStubLabel this_mod
    
    120 123
         decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi
    
    121 124
         body = text "hs_hpc_module" <>
    
    122 125
                   parens (hcat (punctuate comma [
    
    123
    -                  doubleQuotes full_name_str,
    
    126
    +                  doubleQuotes (hpcModuleName this_mod),
    
    124 127
                       int tickCount, -- really StgWord32
    
    125 128
                       int hashNo,    -- really StgWord32
    
    126 129
                       tickboxes
    
    127 130
                     ])) <> semi
    
    131
    +    tickboxes = hpcTickBoxes platform this_mod
    
    128 132
     
    
    129
    -    tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)
    
    130
    -
    
    131
    -    module_name  = hcat (map (text.charToC) $ BS.unpack $
    
    132
    -                         bytesFS (moduleNameFS (moduleName this_mod)))
    
    133
    -    package_name = hcat (map (text.charToC) $ BS.unpack $
    
    134
    -                         bytesFS (unitFS  (moduleUnit this_mod)))
    
    135
    -    full_name_str
    
    136
    -       | moduleUnit this_mod == mainUnit
    
    137
    -       = module_name
    
    138
    -       | otherwise
    
    139
    -       = package_name <> char '/' <> module_name
    133
    +hpcStubLabel :: Module -> CLabel
    
    134
    +hpcStubLabel this_mod = mkInitializerStubLabel this_mod (fsLit "hpc")
    
    135
    +
    
    136
    +hpcModuleName :: Module -> SDoc
    
    137
    +hpcModuleName this_mod =  full_name_str
    
    138
    +  where
    
    139
    +  full_name_str
    
    140
    +    | moduleUnit this_mod == mainUnit
    
    141
    +    = module_name
    
    142
    +    | otherwise
    
    143
    +    = package_name <> char '/' <> module_name
    
    144
    +  module_name  = hcat (map (text.charToC) $ BS.unpack $
    
    145
    +                    bytesFS (moduleNameFS (moduleName this_mod)))
    
    146
    +
    
    147
    +  package_name = hcat (map (text.charToC) $ BS.unpack $
    
    148
    +                        bytesFS (unitFS  (moduleUnit this_mod)))
    
    149
    +
    
    150
    +hpcTickBoxes :: Platform -> Module -> SDoc
    
    151
    +hpcTickBoxes platform this_mod = pprCLabel platform (mkHpcTicksLabel this_mod)

  • compiler/GHC/Iface/Tidy.hs
    ... ... @@ -402,6 +402,7 @@ tidyProgram opts (ModGuts { mg_module = mod
    402 402
                               , mg_foreign_files    = foreign_files
    
    403 403
                               , mg_modBreaks        = modBreaks
    
    404 404
                               , mg_boot_exports     = boot_exports
    
    405
    +                          , mg_hpc_info         = hpc_info
    
    405 406
                               }) = do
    
    406 407
     
    
    407 408
       (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod tcs binds imp_rules
    
    ... ... @@ -471,6 +472,7 @@ tidyProgram opts (ModGuts { mg_module = mod
    471 472
                      , cg_dep_pkgs      = S.map snd (dep_direct_pkgs deps)
    
    472 473
                      , cg_modBreaks     = modBreaks
    
    473 474
                      , cg_spt_entries   = spt_entries
    
    475
    +                 , cg_hpc_info      = hpc_info
    
    474 476
                      }
    
    475 477
              , ModDetails { md_types            = tidy_type_env
    
    476 478
                           , md_rules            = tidy_rules
    

  • compiler/GHC/Linker/ByteCode.hs
    ... ... @@ -37,7 +37,7 @@ linkBytecodeLib hsc_env gbcs = do
    37 37
     
    
    38 38
       let bytecodeLib' = BytecodeLib {
    
    39 39
         bytecodeLibUnitId = homeUnitId_ dflags,
    
    40
    -    bytecodeLibFiles = all_cbcs,
    
    40
    +    bytecodeLibFiles = map undefined all_cbcs,
    
    41 41
         bytecodeLibForeign = interpreter_foreign_lib
    
    42 42
       }
    
    43 43
       let output_fn = fromMaybe "a.out" (outputFile dflags)
    
    ... ... @@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files =
    67 67
               return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name)
    
    68 68
             Nothing -> pure Nothing
    
    69 69
         False -> do
    
    70
    -      pure $ Just (InterpreterStaticObjects files)
    \ No newline at end of file
    70
    +      pure $ Just (InterpreterStaticObjects files)

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -137,6 +137,9 @@ import qualified Data.IntMap.Strict as IM
    137 137
     import qualified Data.Map.Strict as M
    
    138 138
     import Foreign.Ptr (nullPtr)
    
    139 139
     import GHC.ByteCode.Serialize
    
    140
    +-- TODO: this import is wrong
    
    141
    +import GHC.HsToCore.Coverage (hpcModuleName)
    
    142
    +import qualified Data.ByteString.Char8 as BS8
    
    140 143
     
    
    141 144
     -- Note [Linkers and loaders]
    
    142 145
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ... ... @@ -988,10 +991,11 @@ dynLinkBCOs interp pls keep_spec bcos =
    988 991
             let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
    
    989 992
                 pls1                     = pls { bcos_loaded = bcos_loaded' }
    
    990 993
     
    
    991
    -            cbcs :: [CompiledByteCode]
    
    992
    -            cbcs = concatMap linkableBCOs new_bcos
    
    994
    +            -- cbcs :: [CompiledByteCode]
    
    995
    +            mbcs = concatMap linkableModuleByteCodes new_bcos
    
    996
    +            m = map (\ mbc -> (gbc_module mbc, gbc_compiled_byte_code mbc)) mbcs
    
    993 997
             in do
    
    994
    -          bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec cbcs
    
    998
    +          bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec m
    
    995 999
               return $! pls1 { bco_loader_state = bco_state }
    
    996 1000
     
    
    997 1001
     dynLinkCompiledByteCode :: Interp
    
    ... ... @@ -999,9 +1003,10 @@ dynLinkCompiledByteCode :: Interp
    999 1003
                             -> BytecodeLoaderState
    
    1000 1004
                             -> BytecodeLoaderStateTraverser IO  -- ^ The traverser tells us to update home package bytecode state or external package bytecode state
    
    1001 1005
                             -> KeepModuleLinkableDefinitions
    
    1002
    -                        -> [CompiledByteCode]
    
    1006
    +                        -> [(Module, CompiledByteCode)]
    
    1003 1007
                             -> IO BytecodeLoaderState
    
    1004
    -dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec cbcs = do
    
    1008
    +dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec mbcs = do
    
    1009
    +        let cbcs = map snd mbcs
    
    1005 1010
             st1 <- traverse_bytecode_state whole_bytecode_state $ \bytecode_state -> do
    
    1006 1011
               let
    
    1007 1012
                   le1 = bco_linker_env bytecode_state
    
    ... ... @@ -1030,6 +1035,8 @@ dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecod
    1030 1035
               let ce2 = extendClosureEnv (closure_env (bco_linker_env bytecode_state)) new_binds
    
    1031 1036
               -- Add SPT entries
    
    1032 1037
               mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs)
    
    1038
    +          -- Load HPC modules
    
    1039
    +          mapM_ (\(modn, cbc) -> linkHpcEntry interp modn (bc_hpc_info cbc)) mbcs
    
    1033 1040
               return $! bytecode_state { bco_linker_env = (bco_linker_env bytecode_state) { closure_env = ce2 } }
    
    1034 1041
     
    
    1035 1042
     -- | Register SPT entries for this module in the interpreter
    
    ... ... @@ -1042,8 +1049,18 @@ linkSptEntry interp ce (SptEntry name fpr) = do
    1042 1049
         Nothing -> pprPanic "linkSptEntry" (ppr name)
    
    1043 1050
         Just (_, hval) -> addSptEntry interp fpr hval
    
    1044 1051
     
    
    1045
    -
    
    1046
    -
    
    1052
    +linkHpcEntry :: Interp -> Module -> Maybe ByteCodeHpcInfo -> IO ()
    
    1053
    +linkHpcEntry _interp _modl Nothing = pure ()
    
    1054
    +linkHpcEntry interp modl (Just info) = do
    
    1055
    +  addHpcModule interp
    
    1056
    +    (toBS $ hpcModuleName modl)
    
    1057
    +    (bchi_tick_count info)
    
    1058
    +    (bchi_hash info)
    
    1059
    +    (bchi_tickboxes info)
    
    1060
    +  where
    
    1061
    +    toBS :: SDoc -> ByteString
    
    1062
    +    -- TODO: @fendor showSDocUnsafe is wrong, add info to 'ByteCodeHpcInfo'
    
    1063
    +    toBS = BS8.pack . (++ "\0") . showSDocUnsafe . pprCode
    
    1047 1064
     
    
    1048 1065
     -- Link a bunch of BCOs and return references to their values
    
    1049 1066
     linkSomeBCOs :: Interp
    

  • compiler/GHC/Linker/Types.hs
    ... ... @@ -204,36 +204,37 @@ data BytecodeLoaderState = BytecodeLoaderState
    204 204
            -- ^ Information about bytecode objects from the home package we have loaded into the interpreter.
    
    205 205
            , externalPackage_loaded :: BytecodeState
    
    206 206
            -- ^ Information about bytecode objects from external packages we have loaded into the interpreter.
    
    207
    +       , hpcInitialised :: !Bool
    
    207 208
            }
    
    208 209
     
    
    209 210
     
    
    210 211
     -- | Find a name loaded from bytecode
    
    211 212
     lookupNameBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue)
    
    212
    -lookupNameBytecodeState (BytecodeLoaderState home_package external_package) name = do
    
    213
    +lookupNameBytecodeState (BytecodeLoaderState home_package external_package _) name = do
    
    213 214
           lookupNameEnv (closure_env (bco_linker_env home_package)) name
    
    214 215
       <|> lookupNameEnv (closure_env (bco_linker_env external_package)) name
    
    215 216
     
    
    216 217
     -- | Look up a break array in the bytecode loader state.
    
    217 218
     lookupBreakArrayBytecodeState :: BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray)
    
    218
    -lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package) break_mod = do
    
    219
    +lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package _) break_mod = do
    
    219 220
       lookupModuleEnv (breakarray_env (bco_linked_breaks home_package)) break_mod
    
    220 221
       <|> lookupModuleEnv (breakarray_env (bco_linked_breaks external_package)) break_mod
    
    221 222
     
    
    222 223
     -- | Look up an info table in the bytecode loader state.
    
    223 224
     lookupInfoTableBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr)
    
    224
    -lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package) info_mod = do
    
    225
    +lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package _) info_mod = do
    
    225 226
       lookupNameEnv (itbl_env (bco_linker_env home_package)) info_mod
    
    226 227
       <|> lookupNameEnv (itbl_env (bco_linker_env external_package)) info_mod
    
    227 228
     
    
    228 229
     -- | Look up an address in the bytecode loader state.
    
    229 230
     lookupAddressBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr)
    
    230
    -lookupAddressBytecodeState (BytecodeLoaderState home_package external_package) addr_mod = do
    
    231
    +lookupAddressBytecodeState (BytecodeLoaderState home_package external_package _) addr_mod = do
    
    231 232
       lookupNameEnv (addr_env (bco_linker_env home_package)) addr_mod
    
    232 233
       <|> lookupNameEnv (addr_env (bco_linker_env external_package)) addr_mod
    
    233 234
     
    
    234 235
     -- | Look up a cost centre stack in the bytecode loader state.
    
    235 236
     lookupCCSBytecodeState :: BytecodeLoaderState -> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre))
    
    236
    -lookupCCSBytecodeState (BytecodeLoaderState home_package external_package) ccs_mod = do
    
    237
    +lookupCCSBytecodeState (BytecodeLoaderState home_package external_package _) ccs_mod = do
    
    237 238
       lookupModuleEnv (ccs_env (bco_linked_breaks home_package)) ccs_mod
    
    238 239
       <|> lookupModuleEnv (ccs_env (bco_linked_breaks external_package)) ccs_mod
    
    239 240
     
    
    ... ... @@ -241,6 +242,7 @@ emptyBytecodeLoaderState :: BytecodeLoaderState
    241 242
     emptyBytecodeLoaderState = BytecodeLoaderState
    
    242 243
         { homePackage_loaded = emptyBytecodeState
    
    243 244
         , externalPackage_loaded = emptyBytecodeState
    
    245
    +    , hpcInitialised = False
    
    244 246
         }
    
    245 247
     
    
    246 248
     emptyBytecodeState :: BytecodeState
    

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -17,6 +17,7 @@ module GHC.Runtime.Interpreter
    17 17
       , mallocData
    
    18 18
       , createBCOs
    
    19 19
       , addSptEntry
    
    20
    +  , addHpcModule
    
    20 21
       , mkCostCentres
    
    21 22
       , costCentreStackInfo
    
    22 23
       , newBreakArray
    
    ... ... @@ -366,6 +367,10 @@ addSptEntry interp fpr ref =
    366 367
       withForeignRef ref $ \val ->
    
    367 368
         interpCmd interp (AddSptEntry fpr val)
    
    368 369
     
    
    370
    +addHpcModule :: Interp -> ByteString -> Int -> Int -> ByteString -> IO ()
    
    371
    +addHpcModule interp modLabel tickNo hash tickboxes  =
    
    372
    +  interpCmd interp (AddHpcModule modLabel tickNo hash tickboxes)
    
    373
    +
    
    369 374
     costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]
    
    370 375
     costCentreStackInfo interp ccs =
    
    371 376
       interpCmd interp (CostCentreStackInfo ccs)
    

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -74,7 +74,6 @@ import Data.List ( genericReplicate, intersperse
    74 74
     import Foreign hiding (shiftL, shiftR)
    
    75 75
     import Control.Monad
    
    76 76
     import Data.Char
    
    77
    -import Data.Word
    
    78 77
     
    
    79 78
     import GHC.Unit.Module
    
    80 79
     
    
    ... ... @@ -108,8 +107,9 @@ byteCodeGen :: HscEnv
    108 107
                 -> [TyCon]
    
    109 108
                 -> Maybe ModBreaks
    
    110 109
                 -> [SptEntry]
    
    110
    +            -> Maybe ByteCodeHpcInfo
    
    111 111
                 -> IO CompiledByteCode
    
    112
    -byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
    
    112
    +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries hpc_info
    
    113 113
        = withTiming logger
    
    114 114
                     (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
    
    115 115
                     (const ()) $ do
    
    ... ... @@ -135,7 +135,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
    135 135
             let mod_breaks = case mb_modBreaks of
    
    136 136
                  Nothing -> Nothing
    
    137 137
                  Just mb -> Just $ mkInternalModBreaks this_mod breakInfo mb
    
    138
    -        cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries
    
    138
    +        cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries hpc_info
    
    139 139
     
    
    140 140
             -- Squash space leaks in the CompiledByteCode.  This is really
    
    141 141
             -- important, because when loading a set of modules into GHCi
    

  • compiler/GHC/Types/HpcInfo.hs
    ... ... @@ -18,4 +18,3 @@ data HpcInfo
    18 18
     
    
    19 19
     emptyHpcInfo :: HpcInfo
    
    20 20
     emptyHpcInfo = NoHpcInfo
    21
    -

  • compiler/GHC/Unit/Module/ModGuts.hs
    ... ... @@ -141,8 +141,9 @@ data CgGuts
    141 141
             cg_dep_pkgs  :: !(Set UnitId),      -- ^ Dependent packages, used to
    
    142 142
                                                 -- generate #includes for C code gen
    
    143 143
             cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
    
    144
    -        cg_spt_entries :: [SptEntry]
    
    144
    +        cg_spt_entries :: [SptEntry],
    
    145 145
                     -- ^ Static pointer table entries for static forms defined in
    
    146 146
                     -- the module.
    
    147 147
                     -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"
    
    148
    +        cg_hpc_info :: HpcInfo
    
    148 149
         }

  • libraries/ghci/GHCi/Coverage.hs
    1
    +{-# LANGUAGE TupleSections #-}
    
    2
    +{-# LANGUAGE ForeignFunctionInterface #-}
    
    3
    +{-# LANGUAGE LambdaCase #-}
    
    4
    +
    
    5
    +module GHCi.Coverage ( hpcAddModule ) where
    
    6
    +
    
    7
    +import Prelude -- See note [Why do we import Prelude here?]
    
    8
    +import Data.Word
    
    9
    +import Foreign
    
    10
    +import GHC.Fingerprint
    
    11
    +import GHCi.RemoteTypes
    
    12
    +import Data.ByteString
    
    13
    +import GHC.Foreign (CString)
    
    14
    +import qualified Data.ByteString.Unsafe as B
    
    15
    +import qualified Data.ByteString.Char8 as BS8
    
    16
    +import GHCi.ObjLink (lookupSymbol)
    
    17
    +import Debug.Trace
    
    18
    +
    
    19
    +-- | Used by GHCi to add an SPT entry for a set of interactive bindings.
    
    20
    +hpcAddModule :: ByteString -> Int -> Int -> ByteString -> IO ()
    
    21
    +hpcAddModule modl ticks hash tickboxes = do
    
    22
    +  B.unsafeUseAsCString modl $ \modlLiteral -> do
    
    23
    +    lookupSymbol (BS8.unpack tickboxes) >>= \ case
    
    24
    +      Nothing -> pure ()
    
    25
    +      Just tickBoxRef -> do
    
    26
    +        hpc_register_module modlLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef)
    
    27
    +        hpc_startup
    
    28
    +
    
    29
    +foreign import ccall "hs_hpc_module"
    
    30
    +    hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO ()
    
    31
    +
    
    32
    +foreign import ccall "startupHpc"
    
    33
    +    hpc_startup :: IO ()

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -111,6 +111,8 @@ data Message a where
    111 111
     
    
    112 112
       -- | Add entries to the Static Pointer Table
    
    113 113
       AddSptEntry :: Fingerprint -> HValueRef -> Message ()
    
    114
    +  -- | Add module to hpc
    
    115
    +  AddHpcModule :: ByteString -> Int -> Int -> ByteString -> Message ()
    
    114 116
     
    
    115 117
       -- | Malloc some data and return a 'RemotePtr' to it
    
    116 118
       MallocData :: ByteString -> Message (RemotePtr ())
    
    ... ... @@ -602,6 +604,7 @@ getMessage = do
    602 604
           38 -> Msg <$> (ResumeSeq <$> get)
    
    603 605
           39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
    
    604 606
           40 -> Msg <$> (WhereFrom <$> get)
    
    607
    +      41 -> Msg <$> (AddHpcModule <$> get <*> get <*> get <*> get)
    
    605 608
           _  -> error $ "Unknown Message code " ++ (show b)
    
    606 609
     
    
    607 610
     putMessage :: Message a -> Put
    
    ... ... @@ -648,6 +651,7 @@ putMessage m = case m of
    648 651
       ResumeSeq a                 -> putWord8 38 >> put a
    
    649 652
       LookupSymbolInDLL dll str   -> putWord8 39 >> put dll >> put str
    
    650 653
       WhereFrom a                 -> putWord8 40 >> put a
    
    654
    +  AddHpcModule lbl ticks hash tickboxes -> putWord8 41 >> put lbl >> put ticks >> put hash >> put tickboxes
    
    651 655
     
    
    652 656
     {-
    
    653 657
     Note [Parallelize CreateBCOs serialization]
    

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -19,6 +19,7 @@ import GHCi.CreateBCO
    19 19
     import GHCi.InfoTable
    
    20 20
     #endif
    
    21 21
     
    
    22
    +import GHCi.Coverage
    
    22 23
     import qualified GHC.InfoProv as InfoProv
    
    23 24
     import GHCi.Debugger
    
    24 25
     import GHCi.FFI
    
    ... ... @@ -88,6 +89,7 @@ run m = case m of
    88 89
         fmap toRemotePtr <$> lookupSymbolInDLL (fromRemotePtr dll) str
    
    89 90
       FreeHValueRefs rs -> mapM_ freeRemoteRef rs
    
    90 91
       AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
    
    92
    +  AddHpcModule modl ticks hash tickboxes -> hpcAddModule modl ticks hash tickboxes
    
    91 93
       EvalStmt opts r -> evalStmt opts r
    
    92 94
       ResumeStmt opts r -> resumeStmt opts r
    
    93 95
       AbandonStmt r -> abandonStmt r
    

  • libraries/ghci/ghci.cabal.in
    ... ... @@ -59,6 +59,7 @@ library
    59 59
         if flag(internal-interpreter)
    
    60 60
             CPP-Options: -DHAVE_INTERNAL_INTERPRETER
    
    61 61
             exposed-modules:
    
    62
    +            GHCi.Coverage
    
    62 63
                 GHCi.Run
    
    63 64
                 GHCi.Debugger
    
    64 65
                 GHCi.CreateBCO
    

  • rts/Hpc.c
    ... ... @@ -323,8 +323,6 @@ hs_hpc_module(char *modName,
    323 323
           }
    
    324 324
           tmpModule->from_file = false;
    
    325 325
       }
    
    326
    -
    
    327
    -  startupHpc();
    
    328 326
     }
    
    329 327
     
    
    330 328
     static void
    

  • rts/Interpreter.c
    ... ... @@ -2111,6 +2111,9 @@ run_BCO:
    2111 2111
                 W_ arg1_ticks_array, arg2_tick_index;
    
    2112 2112
                 arg1_ticks_array = BCO_GET_LARGE_ARG;
    
    2113 2113
                 arg2_tick_index  = BCO_READ_NEXT_32;
    
    2114
    +            IF_DEBUG(hpc,
    
    2115
    +                     debugBelch("\tHPC Tick %lu %lu %lu\n", BCO_LIT(arg1_ticks_array), arg1_ticks_array, arg2_tick_index);
    
    2116
    +                );
    
    2114 2117
     
    
    2115 2118
                 ((StgWord64*)BCO_LIT(arg1_ticks_array))[arg2_tick_index]++;
    
    2116 2119
                 NEXT_INSTRUCTION;