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 :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
writeMixEntries FilePath
hpc_dir Module
mod SizedSeq Tick
extendedMixEntries FilePath
filename
= do
let count :: Int
count = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. SizedSeq a -> Word
sizeSS SizedSeq Tick
extendedMixEntries
entries :: [Tick]
entries = forall a. SizedSeq a -> [a]
ssElts SizedSeq Tick
extendedMixEntries
mod_name :: FilePath
mod_name = ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
hpc_mod_dir :: FilePath
hpc_mod_dir
| forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
mainUnit = FilePath
hpc_dir
| Bool
otherwise = FilePath
hpc_dir forall a. [a] -> [a] -> [a]
++ FilePath
"/" forall a. [a] -> [a] -> [a]
++ forall u. IsUnitId u => u -> FilePath
unitString (forall unit. GenModule unit -> unit
moduleUnit Module
mod)
tabStop :: Int
tabStop = Int
8
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
hpc_mod_dir
UTCTime
modTime <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
filename
let entries' :: [(HpcPos, BoxLabel)]
entries' = [ (HpcPos
hpcPos, Tick -> BoxLabel
tick_label Tick
t)
| Tick
t <- [Tick]
entries, HpcPos
hpcPos <- [SrcSpan -> HpcPos
mkHpcPos forall a b. (a -> b) -> a -> b
$ Tick -> SrcSpan
tick_loc Tick
t] ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(HpcPos, BoxLabel)]
entries' forall a. [a] -> Int -> Bool
`lengthIsNot` Int
count) forall a b. (a -> b) -> a -> b
$
forall a. FilePath -> a
panic FilePath
"the number of .mix entries are inconsistent"
let hashNo :: Int
hashNo = FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
filename UTCTime
modTime Int
tabStop [(HpcPos, BoxLabel)]
entries'
FilePath -> FilePath -> Mix -> IO ()
mixCreate FilePath
hpc_mod_dir FilePath
mod_name
forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> Hash -> Int -> [(HpcPos, BoxLabel)] -> Mix
Mix FilePath
filename UTCTime
modTime (forall a. HpcHash a => a -> Hash
toHash Int
hashNo) Int
tabStop [(HpcPos, BoxLabel)]
entries'
forall (m :: * -> *) a. Monad m => a -> m a
return Int
hashNo
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos :: SrcSpan
pos@(RealSrcSpan RealSrcSpan
s Maybe BufSpan
_)
| SrcSpan -> Bool
isGoodSrcSpan' SrcSpan
pos = (Int, Int, Int, Int) -> HpcPos
toHpcPos (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s,
RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s,
RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s,
RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s forall a. Num a => a -> a -> a
- Int
1)
mkHpcPos SrcSpan
_ = forall a. FilePath -> a
panic FilePath
"bad source span; expected such spans to be filtered out"
mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
mixHash :: FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
file UTCTime
tm Int
tabstop [(HpcPos, BoxLabel)]
entries = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FilePath -> Int32
hashString
(forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> Hash -> Int -> [(HpcPos, BoxLabel)] -> Mix
Mix FilePath
file UTCTime
tm Hash
0 Int
tabstop [(HpcPos, BoxLabel)]
entries)
hpcInitCode :: Platform -> Module -> HpcInfo -> CStub
hpcInitCode :: Platform -> Module -> HpcInfo -> CStub
hpcInitCode Platform
_ Module
_ (NoHpcInfo {}) = forall a. Monoid a => a
mempty
hpcInitCode Platform
platform Module
this_mod (HpcInfo Int
tickCount Int
hashNo)
= Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
fn_name SDoc
decls SDoc
body
where
fn_name :: CLabel
fn_name = Module -> FilePath -> CLabel
mkInitializerStubLabel Module
this_mod FilePath
"hpc"
decls :: SDoc
decls = FilePath -> SDoc
text FilePath
"extern StgWord64 " SDoc -> SDoc -> SDoc
<> SDoc
tickboxes SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[]" SDoc -> SDoc -> SDoc
<> SDoc
semi
body :: SDoc
body = FilePath -> SDoc
text FilePath
"hs_hpc_module" SDoc -> SDoc -> SDoc
<>
SDoc -> SDoc
parens ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [
SDoc -> SDoc
doubleQuotes SDoc
full_name_str,
Int -> SDoc
int Int
tickCount,
Int -> SDoc
int Int
hashNo,
SDoc
tickboxes
])) SDoc -> SDoc -> SDoc
<> SDoc
semi
tickboxes :: SDoc
tickboxes = Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (Module -> CLabel
mkHpcTicksLabel forall a b. (a -> b) -> a -> b
$ Module
this_mod)
module_name :: SDoc
module_name = [SDoc] -> SDoc
hcat (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
textforall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack forall a b. (a -> b) -> a -> b
$
FastString -> ByteString
bytesFS (ModuleName -> FastString
moduleNameFS (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)))
package_name :: SDoc
package_name = [SDoc] -> SDoc
hcat (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
textforall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack forall a b. (a -> b) -> a -> b
$
FastString -> ByteString
bytesFS (forall u. IsUnitId u => u -> FastString
unitFS (forall unit. GenModule unit -> unit
moduleUnit Module
this_mod)))
full_name_str :: SDoc
full_name_str
| forall unit. GenModule unit -> unit
moduleUnit Module
this_mod forall a. Eq a => a -> a -> Bool
== Unit
mainUnit
= SDoc
module_name
| Bool
otherwise
= SDoc
package_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> SDoc
module_name