{-
(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 :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
writeMixEntries FilePath
hpc_dir Module
mod SizedSeq Tick
extendedMixEntries FilePath
filename
  = do
        let count :: Int
count = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ SizedSeq Tick -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq Tick
extendedMixEntries
            entries :: [Tick]
entries = SizedSeq Tick -> [Tick]
forall a. SizedSeq a -> [a]
ssElts SizedSeq Tick
extendedMixEntries

            mod_name :: FilePath
mod_name = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

            hpc_mod_dir :: FilePath
hpc_mod_dir
              | Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit  = FilePath
hpc_dir
              | Bool
otherwise = FilePath
hpc_dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Unit -> FilePath
forall u. IsUnitId u => u -> FilePath
unitString (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod)

            tabStop :: Int
tabStop = Int
8 -- <tab> counts as a normal char in GHC's
                        -- location ranges.

        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
hpc_mod_dir
        modTime <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
filename
        let entries' = [ (HpcPos
hpcPos, Tick -> BoxLabel
tick_label Tick
t)
                       | Tick
t <- [Tick]
entries, HpcPos
hpcPos <- [SrcSpan -> HpcPos
mkHpcPos (SrcSpan -> HpcPos) -> SrcSpan -> HpcPos
forall a b. (a -> b) -> a -> b
$ Tick -> SrcSpan
tick_loc Tick
t] ]
        when (entries' `lengthIsNot` count) $
          panic "the number of .mix entries are inconsistent"
        let hashNo = FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
filename UTCTime
modTime Int
tabStop [(HpcPos, BoxLabel)]
entries'
        mixCreate hpc_mod_dir mod_name
                       $ Mix filename modTime (toHash hashNo) tabStop entries'
        return 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 SrcSpan
_ = FilePath -> HpcPos
forall a. HasCallStack => FilePath -> a
panic FilePath
"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 :: FilePath -> UTCTime -> Int -> [(HpcPos, BoxLabel)] -> Int
mixHash FilePath
file UTCTime
tm Int
tabstop [(HpcPos, BoxLabel)]
entries = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int32
hashString
        (Mix -> FilePath
forall a. Show a => a -> FilePath
show (Mix -> FilePath) -> Mix -> FilePath
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)

{-
************************************************************************
*                                                                      *
*              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 :: Platform -> Module -> HpcInfo -> CStub
hpcInitCode Platform
_ Module
_ (NoHpcInfo {}) = CStub
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 -> FastString -> CLabel
mkInitializerStubLabel Module
this_mod (FilePath -> FastString
fsLit FilePath
"hpc")
    decls :: SDoc
decls = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"StgWord64 " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
tickboxes SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
tickCount) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
    body :: SDoc
body = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"hs_hpc_module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
              SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [
                  SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes SDoc
full_name_str,
                  Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
tickCount, -- really StgWord32
                  Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
hashNo,    -- really StgWord32
                  SDoc
tickboxes
                ])) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

    tickboxes :: SDoc
tickboxes = Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform (Module -> CLabel
mkHpcTicksLabel (Module -> CLabel) -> Module -> CLabel
forall a b. (a -> b) -> a -> b
$ Module
this_mod)

    module_name :: SDoc
module_name  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ((Word8 -> SDoc) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text(FilePath -> SDoc) -> (Word8 -> FilePath) -> Word8 -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) ([Word8] -> [SDoc]) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)))
    package_name :: SDoc
package_name = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ((Word8 -> SDoc) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text(FilePath -> SDoc) -> (Word8 -> FilePath) -> Word8 -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> FilePath
charToC) ([Word8] -> [SDoc]) -> [Word8] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$
                         FastString -> ByteString
bytesFS (Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS  (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_mod)))
    full_name_str :: SDoc
full_name_str
       | Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit
       = SDoc
module_name
       | Bool
otherwise
       = SDoc
package_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
module_name