1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}
module GHC.HsToCore.Coverage
( writeMixEntries
, hpcInitCode
) where
import GHC.Prelude as Prelude
import GHC.Unit
import GHC.HsToCore.Ticks
import GHC.Platform
import GHC.Data.FastString
import GHC.Data.SizedSeq
import GHC.Cmm.CLabel
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Types.ForeignStubs
import GHC.Types.HpcInfo
import GHC.Types.SrcLoc
import Control.Monad
import Data.Time
import System.Directory
import Trace.Hpc.Mix
import Trace.Hpc.Util
import qualified Data.ByteString as BS
writeMixEntries
:: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
writeMixEntries hpc_dir mod extendedMixEntries filename
= do
let count = fromIntegral $ sizeSS extendedMixEntries
entries = ssElts extendedMixEntries
mod_name = moduleNameString (moduleName mod)
hpc_mod_dir
| moduleUnit mod == mainUnit = hpc_dir
| otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)
tabStop = 8 -- <tab> counts as a normal char in GHC's
-- location ranges.
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationUTCTime filename
let entries' = [ (hpcPos, tick_label t)
| t <- entries, hpcPos <- [mkHpcPos $ tick_loc t] ]
when (entries' `lengthIsNot` count) $
panic "the number of .mix entries are inconsistent"
let hashNo = mixHash filename modTime tabStop entries'
mixCreate hpc_mod_dir mod_name
$ Mix filename modTime (toHash hashNo) tabStop entries'
return hashNo
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s _)
| isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
srcSpanStartCol s,
srcSpanEndLine s,
srcSpanEndCol s - 1)
-- the end column of a SrcSpan is one
-- greater than the last column of the
-- span (see SrcLoc), whereas HPC
-- expects to the column range to be
-- inclusive, hence we subtract one above.
mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
-- For the hash value, we hash everything: the file name,
-- the timestamp of the original source file, the tab stop,
-- and the mix entries. We cheat, and hash the show'd string.
-- This hash only has to be hashed at Mix creation time,
-- and is for sanity checking only.
mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
mixHash file tm tabstop entries = fromIntegral $ hashString
(show $ Mix file tm 0 tabstop entries)
{-
************************************************************************
* *
* initialisation
* *
************************************************************************
-}
{- | Create HPC initialization C code for a module
Each module compiled with -fhpc declares an initialisation function of
the form `hpc_init_<module>()`, which is emitted into the _stub.c file
and annotated with __attribute__((constructor)) so that it gets
executed at startup time.
The function's purpose is to call hs_hpc_module to register this
module with the RTS, and it looks something like this:
> static void hpc_init_Main(void) __attribute__((constructor));
> static void hpc_init_Main(void)
> {
> extern StgWord64 _hpc_tickboxes_Main_hpc[];
> hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);
> }
-}
hpcInitCode :: Platform -> Module -> HpcInfo -> CStub
hpcInitCode _ _ (NoHpcInfo {}) = mempty
hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
= initializerCStub platform fn_name decls body
where
fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")
decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi
body = text "hs_hpc_module" <>
parens (hcat (punctuate comma [
doubleQuotes full_name_str,
int tickCount, -- really StgWord32
int hashNo, -- really StgWord32
tickboxes
])) <> semi
tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)
module_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (moduleNameFS (moduleName this_mod)))
package_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (unitFS (moduleUnit this_mod)))
full_name_str
| moduleUnit this_mod == mainUnit
= module_name
| otherwise
= package_name <> char '/' <> module_name
|
