\section[Coverage]{@coverage@: the main function}
\begin{code}
-module Coverage (addCoverageTicksToBinds) where
+module Coverage (addCoverageTicksToBinds, hpcInitCode) where
import HsSyn
import Module
import TyCon
import MonadUtils
import Maybes
+import CLabel
+import Util
import Data.Array
import System.Directory ( createDirectoryIfMissing )
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
+addTickHsExpr (HsDo cxt stmts last_exp return_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
+ return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
+ return (HsDo cxt stmts' last_exp' return_exp' srcloc)
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
(return w)
(addTickHsExpr e) -- explicitly no tick on inside
+addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) =
+ liftM5 HsArrApp
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (return ty1)
+ (return arr_ty)
+ (return lr)
+
+addTickHsExpr (HsArrForm e fix cmdtop) =
+ liftM3 HsArrForm
+ (addTickLHsExpr e)
+ (return fix)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
addTickHsExpr e@(HsType _) = return e
-- Others dhould never happen in expression content.
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' ty) = do
- liftM3 ExprStmt
+addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
+ liftM4 ExprStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs) = do
- liftM ParStmt
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
+ liftM4 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
-
-addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
- liftM4 TransformStmt
- (addTickLStmts isGuard stmts)
- (return ids)
- (addTickLHsExprAlways usingExpr)
- (addTickMaybeByLHsExpr maybeByExpr)
-
-addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
- liftM4 GroupStmt
- (addTickLStmts isGuard stmts)
- (return binderMap)
- (fmapMaybeM addTickLHsExprAlways by)
- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+ (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+ (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr returnExpr bindExpr) = do
+ t_s <- (addTickLStmts isGuard stmts)
+ t_u <- (addTickLHsExprAlways usingExpr)
+ t_m <- (addTickMaybeByLHsExpr maybeByExpr)
+ t_r <- (addTickSyntaxExpr hpcSrcSpan returnExpr)
+ t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ return $ TransformStmt t_s ids t_u t_m t_r t_b
+
+addTickStmt isGuard (GroupStmt stmts binderMap by using returnExpr bindExpr liftMExpr) = do
+ t_s <- (addTickLStmts isGuard stmts)
+ t_y <- (fmapMaybeM addTickLHsExprAlways by)
+ t_u <- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+ t_f <- (addTickSyntaxExpr hpcSrcSpan returnExpr)
+ t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ t_m <- (addTickSyntaxExpr hpcSrcSpan liftMExpr)
+ return $ GroupStmt t_s binderMap t_y t_u t_b t_f t_m
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
+addTickHsCmd (HsDo cxt stmts last_exp return_exp srcloc) = do
(stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
- where
+ return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
+ return (HsDo cxt stmts' last_exp' return_exp' srcloc)
+
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
(addTickLHsExpr e1)
(addTickLHsCmd c)
(return bind)
(return fail)
-addTickCmdStmt (ExprStmt c bind' ty) = do
- liftM3 ExprStmt
+addTickCmdStmt (ExprStmt c bind' guard' ty) = do
+ liftM4 ExprStmt
(addTickLHsCmd c)
- (return bind')
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickCmdStmt (LetStmt binds) = do
liftM LetStmt
mixHash file tm tabstop entries = fromIntegral $ hashString
(show $ Mix file tm 0 tabstop entries)
\end{code}
+
+%************************************************************************
+%* *
+%* initialisation
+%* *
+%************************************************************************
+
+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);}
+
+\begin{code}
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+ [ text "static void hpc_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+ , braces (vcat [
+ ptext (sLit "extern StgWord64 ") <> tickboxes <>
+ ptext (sLit "[]") <> semi,
+ ptext (sLit "hs_hpc_module") <>
+ parens (hcat (punctuate comma [
+ doubleQuotes full_name_str,
+ int tickCount, -- really StgWord32
+ int hashNo, -- really StgWord32
+ tickboxes
+ ])) <> semi
+ ])
+ ]
+ where
+ tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)
+
+ module_name = hcat (map (text.charToC) $
+ bytesFS (moduleNameFS (Module.moduleName this_mod)))
+ package_name = hcat (map (text.charToC) $
+ bytesFS (packageIdFS (modulePackageId this_mod)))
+ full_name_str
+ | modulePackageId this_mod == mainPackageId
+ = module_name
+ | otherwise
+ = package_name <> char '/' <> module_name
+\end{code}
projects / ghc-hetmet.git / blobdiff