mkPicBaseLabel,
mkDeadStripPreventer,
+ mkHpcTicksLabel,
+ mkHpcModuleNameLabel,
+
infoLblToEntryLbl, entryLblToInfoLbl,
needsCDecl, isAsmTemp, externallyVisibleCLabel,
CLabelType(..), labelType, labelDynamic,
| DeadStripPreventer CLabel
-- label before an info table to prevent excessive dead-stripping on darwin
+ | HpcTicksLabel Module -- Per-module table of tick locations
+ | HpcModuleNameLabel -- Per-module name of the module for Hpc
+
deriving (Eq, Ord)
data IdLabelInfo
mkRtsSlowTickyCtrLabel :: String -> CLabel
mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+ -- Coverage
+
+mkHpcTicksLabel = HpcTicksLabel
+mkHpcModuleNameLabel = HpcModuleNameLabel
+
-- Dynamic linking
mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
needsCDecl (ForeignLabel _ _ _) = False
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
+needsCDecl (HpcTicksLabel _) = True
+needsCDecl HpcModuleNameLabel = False
-- Whether the label is an assembler temporary:
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
+externallyVisibleCLabel (HpcTicksLabel _) = True
+externallyVisibleCLabel HpcModuleNameLabel = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
pprCLbl (PlainModuleInitLabel mod _)
= ptext SLIT("__stginit_") <> ppr mod
+pprCLbl (HpcTicksLabel mod)
+ = ptext SLIT("_tickboxes_") <> ppr mod <> ptext SLIT("_hpc")
+
+pprCLbl HpcModuleNameLabel
+ = ptext SLIT("_hpc_module_name_str")
+
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <>
(case x of
import CgInfoTbls
import CgForeignCall
import CgPrimOp
+import CgHpc
import CgUtils
import ClosureInfo
import Cmm
\end{code}
%********************************************************
+%* *
+%* Hpc Tick Boxes *
+%* *
+%********************************************************
+
+\begin{code}
+cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
+\end{code}
+
+%********************************************************
%* *
%* Non-top-level bindings *
%* *
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for coverage
+--
+-- (c) Galois Connections, Inc. 2006
+--
+-----------------------------------------------------------------------------
+
+module CgHpc (cgTickBox, initHpc, hpcTable) where
+
+import Cmm
+import CLabel
+import Module
+import MachOp
+import CmmUtils
+import CgMonad
+import CgForeignCall
+import ForeignCall
+import FastString
+import HscTypes
+import Char
+
+cgTickBox :: Module -> Int -> Code
+cgTickBox mod n = do
+ let tick_box = (cmmIndex I64
+ (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
+ (fromIntegral n)
+ )
+ stmtsC [ CmmStore tick_box
+ (CmmMachOp (MO_Add I64)
+ [ CmmLoad tick_box I64
+ , CmmLit (mkIntCLit 1)
+ ])
+ ]
+
+
+hpcTable :: Module -> HpcInfo -> Code
+hpcTable this_mod hpc_tickCount = do
+ emitData ReadOnlyData
+ [ CmmDataLabel mkHpcModuleNameLabel
+ , CmmString $ map (fromIntegral . ord)
+ (module_name_str)
+ ++ [0]
+ ]
+ emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
+ ] ++
+ [ CmmStaticLit (CmmInt 0 I64)
+ | _ <- take hpc_tickCount [0..]
+ ]
+ where
+ module_name_str = moduleNameString (Module.moduleName this_mod)
+
+
+initHpc :: Module -> HpcInfo -> Code
+initHpc this_mod tickCount
+ = do { emitForeignCall'
+ PlayRisky
+ []
+ (CmmForeignCall
+ (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
+ CCallConv
+ )
+ [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
+ , (CmmLit $ mkIntCLit tickCount,NoHint)
+ , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
+ ]
+ (Just [])
+ }
+ where
+ mod_alloc = mkFastString "hs_hpc_module"
+
import CgClosure
import CgCon
import CgUtils
+import CgHpc
import CLabel
import Cmm
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
+ -> HpcInfo
-> IO [Cmm] -- Output
codeGen dflags this_mod data_tycons foreign_stubs imported_mods
- cost_centre_info stg_binds
+ cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "CodeGen"
; let way = buildTag dflags
; cmm_tycons <- mapM cgTyCon data_tycons
; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info
this_mod main_mod
- foreign_stubs imported_mods)
+ foreign_stubs imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
}
-- Put datatype_stuff after code_stuff, because the
-> Module -- name of the Main module
-> ForeignStubs
-> [Module]
+ -> HpcInfo
-> Code
-mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods
- = do {
- if opt_SccProfilingOn
- then do { -- Allocate the static boolean that records if this
- -- module has been registered already
- emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
+mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info
+ = do { -- Allocate the static boolean that records if this
+ -- module has been registered already
+ emitData Data [CmmDataLabel moduleRegdLabel,
+ CmmStaticLit zeroCLit]
- ; emitSimpleProc real_init_lbl $ do
- { ret_blk <- forkLabelledCode ret_code
+ ; whenC (dopt Opt_Hpc dflags) $
+ hpcTable this_mod hpc_info
+
+ -- we emit a recursive descent module search for all modules
+ -- and *choose* to chase it in :Main, below.
+ -- In this way, Hpc enabled modules can interact seamlessly with
+ -- not Hpc enabled moduled, provided Main is compiled with Hpc.
+
+ ; emitSimpleProc real_init_lbl $ do
+ { ret_blk <- forkLabelledCode ret_code
; init_blk <- forkLabelledCode $ do
{ mod_init_code; stmtC (CmmBranch ret_blk) }
ret_blk)
; stmtC (CmmBranch init_blk)
}
- }
- else emitSimpleProc real_init_lbl ret_code
-- Make the "plain" procedure jump to the "real" init procedure
; emitSimpleProc plain_init_lbl jump_to_init
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
+
+ -- Notice that the recursive descent is optional, depending on what options
+ -- are enabled.
+
; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl jump_to_init)
+ (emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
this_pkg = thisPackage dflags
{ -- Set mod_reg to 1 to record that we've been here
stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
- -- Now do local stuff
- ; initCostCentres cost_centre_info
+ ; whenC (opt_SccProfilingOn) $ do
+ initCostCentres cost_centre_info
+
+ ; whenC (dopt Opt_Hpc dflags) $
+ initHpc this_mod hpc_info
+
; mapCs (registerModuleImport this_pkg way)
(imported_mods++extra_imported_mods)
+
}
-- The return-code pops the work stack by
ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
, CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
+
+ rec_descent_init = if opt_SccProfilingOn || dopt Opt_Hpc dflags
+ then jump_to_init
+ else ret_code
+
-----------------------
registerModuleImport :: PackageId -> String -> Module -> Code
registerModuleImport this_pkg way mod
import DynFlags
import Util
import Outputable
+import TysWiredIn
\end{code}
-- ---------------------------------------------------------------------------
exprIsTrivial (Lit lit) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) = False
+exprIsTrivial (Note (TickBox {}) e) = False
+exprIsTrivial (Note (BinaryTickBox {}) e) = False
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
returnUs (floats, Note n expr2)
+corePrepExprFloat env (Note note@(TickBox {}) expr)
+ = corePrepAnExpr env expr `thenUs` \ expr1 ->
+ deLamFloat expr1 `thenUs` \ (floats, expr2) ->
+ return (floats, Note note expr2)
+
+corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr)
+ = corePrepAnExpr env expr `thenUs` \ expr1 ->
+ deLamFloat expr1 `thenUs` \ (floats, expr2) ->
+ getUniqueUs `thenUs` \ u ->
+ let bndr = mkSysLocal FSLIT("t") u boolTy in
+ return (floats, Case expr2
+ bndr
+ boolTy
+ [ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId))
+ , (DataAlt trueDataCon, [], Note (TickBox m t) (Var trueDataConId))
+ ])
+
corePrepExprFloat env (Note other_note expr)
= corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
returnUs (floats, Note other_note expr')
where
(bndrs,body) = collectBinders expr
+corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts)
+ = corePrepExprFloat env (Note note (Case expr bndr ty alts))
+
+corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts)
+ = do { ASSERT(exprType expr `coreEqType` boolTy)
+ corePrepExprFloat env $
+ Case expr bndr ty
+ [ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch)
+ , (DataAlt trueDataCon, [], Note (TickBox m t) trueBranch)
+ ]
+ }
+ where
+ (_,_,trueBranch) = findAlt (DataAlt trueDataCon) alts
+ (_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts
+
corePrepExprFloat env (Case scrut bndr ty alts)
= corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
import BasicTypes
import FastString
import Outputable
+import Module
infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
| CoreNote String -- A generic core annotation, propagated but not used by GHC
+ | TickBox Module !Int -- ^Tick box for Hpc-style coverage
+ | BinaryTickBox Module !Int !Int
+ -- ^Binary tick box, with a tick for result = True, result = False
+
+
-- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote (CoreNote s) = s `seq` ()
+seqNote (TickBox m n) = m `seq` () -- no need for seq on n, because n is strict
+seqNote (BinaryTickBox m t f)
+ = m `seq` () -- likewise on t and f.
seqNote other = ()
seqBndr b = b `seq` ()
Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
}}
+-- We do not want to tell the world that we have a
+-- Cons, to *stop* Case of Known Cons, which removes
+-- the TickBox.
+exprIsConApp_maybe (Note (TickBox {}) expr)
+ = Nothing
+exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
+ = Nothing
+
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
-- We ignore InlineMe notes in case we have
go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
+ go (Note (TickBox {}) _) = 0
+ go (Note (BinaryTickBox {}) _)
+ = 0
go (Note n e) = go e
go (Cast e _) = go e
go (App e (Type t)) = go e
noteSize (SCC cc) = cc `seq` 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
+noteSize (TickBox m n) = m `seq` n `seq` 1
+noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1
varSize :: Var -> Int
varSize b | isTyVar b = 1
is_static False (Lam b e) = isRuntimeVar b || is_static False e
is_static in_arg (Note (SCC _) e) = False
+ is_static in_arg (Note (TickBox {}) e) = False
+ is_static in_arg (Note (BinaryTickBox {}) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
is_static in_arg (Cast e co) = is_static in_arg e
import Util
import Outputable
import FastString
+import Module
\end{code}
%************************************************************************
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
+ppr_expr add_par (Note (TickBox mod n) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__tick_box"),
+ pprModule mod,
+ text (show n)],
+ pprParendExpr expr]
+
+ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__binary_tick_box"),
+ pprModule mod,
+ text (show t),
+ text (show e)],
+ pprParendExpr expr]
+
ppr_expr add_par (Note (CoreNote s) expr)
= add_par $
sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
--- /dev/null
+%
+% (c) Galois, 2006
+%
+\section[Coverage]{@coverage@: the main function}
+
+\begin{code}
+module Coverage (addCoverageTicksToBinds) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import Id ( Id )
+import DynFlags ( DynFlags, mainModIs, mainFunIs )
+import Module
+import HscTypes ( HpcInfo, noHpcInfo )
+
+import IdInfo
+import Outputable
+import DynFlags ( DynFlag(Opt_D_dump_hpc), hpcDir )
+import Monad
+
+import SrcLoc
+import ErrUtils (doIfSet_dyn)
+import HsUtils ( mkHsApp )
+import Unique
+import UniqSupply
+import Id
+import Name
+import TcType
+import TysPrim
+import CoreUtils
+import TyCon
+import Type
+import TysWiredIn ( intTy , stringTy, unitTy, intDataCon, falseDataConId, mkListTy, pairTyCon, tupleCon, mkTupleTy, unboxedSingletonDataCon )
+import Bag
+import Var ( TyVar, mkTyVar )
+import DataCon ( dataConWrapId )
+import MkId
+import PrimOp
+import BasicTypes ( RecFlag(..), Activation(NeverActive), Boxity(..) )
+import Data.List ( isSuffixOf )
+
+import System.Time (ClockTime(..))
+import System.Directory (getModificationTime)
+import System.IO (FilePath)
+#if __GLASGOW_HASKELL__ < 603
+import Compat.Directory ( createDirectoryIfMissing )
+#else
+import System.Directory ( createDirectoryIfMissing )
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+%* The main function: addCoverageTicksToBinds
+%* *
+%************************************************************************
+
+\begin{code}
+addCoverageTicksToBinds dflags mod mod_loc binds = do
+ let main_mod = mainModIs dflags
+ main_is = case mainFunIs dflags of
+ Nothing -> "main"
+ Just main -> main
+
+ let mod_name = moduleNameString (moduleName mod)
+
+ let (binds1,st)
+ = unTM (addTickLHsBinds binds)
+ $ TT { modName = mod_name
+ , declPath = []
+ , tickBoxCount = 0
+ , mixEntries = []
+ }
+
+ let hpc_dir = hpcDir dflags
+
+ -- write the mix entries for this module
+ let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
+
+ let orig_file = case ml_hs_file mod_loc of
+ Just file -> file
+ Nothing -> error "can not find the original file during hpc trans"
+
+ modTime <- getModificationTime' orig_file
+
+ createDirectoryIfMissing True hpc_dir
+
+ mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
+
+ doIfSet_dyn dflags Opt_D_dump_hpc $ do
+ printDump (pprLHsBinds binds1)
+-- putStrLn (showSDocDebug (pprLHsBinds binds3))
+ return (binds1, tickBoxCount st)
+\end{code}
+
+
+\begin{code}
+liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
+liftL f (L loc a) = do
+ a' <- f a
+ return $ L loc a'
+
+addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
+addTickLHsBinds binds = mapBagM addTickLHsBind binds
+
+addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
+addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
+ abs_binds' <- addTickLHsBinds abs_binds
+ return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
+ let name = getOccString id
+ decl_path <- getPathEntry
+
+ tick_no <- allocATickBox (if null decl_path
+ then TopLevelBox [name]
+ else LocalBox (name : decl_path))
+ pos
+
+ mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)
+ $ addTickMatchGroup (fun_matches funBind)
+ let arg_count = matchGroupArity mg
+ let (tys,res_ty) = splitFunTysN arg_count ty
+
+ return $ L pos $ funBind { fun_matches = MatchGroup ({-L pos fn_entry:-}matches') ty
+ , fun_tick = tick_no
+ }
+
+-- TODO: Revisit this
+addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
+ let name = "(...)"
+ rhs' <- addPathEntry name $ addTickGRHSs False rhs
+{-
+ decl_path <- getPathEntry
+ tick_me <- allocTickBox (if null decl_path
+ then TopLevelBox [name]
+ else LocalBox (name : decl_path))
+-}
+ return $ L pos $ pat { pat_rhs = rhs' }
+
+{- only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind (VarBind var_id var_rhs) = do
+ var_rhs' <- addTickLHsExpr var_rhs
+ return $ VarBind var_id var_rhs'
+-}
+addTickLHsBind other = return other
+
+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr (L pos e0) = do
+ e1 <- addTickHsExpr e0
+ fn <- allocTickBox ExpBox pos
+ return $ fn $ L pos e1
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprOptAlt oneOfMany (L pos e0) = do
+ e1 <- addTickHsExpr e0
+ fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
+ return $ fn $ L pos e1
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by
+-- another.
+addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr' (L pos e0) = do
+ e1 <- addTickHsExpr e0
+ return $ L pos e1
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+addBinTickLHsExpr boxLabel (L pos e0) = do
+ e1 <- addTickHsExpr e0
+ allocBinTickBox boxLabel $ L pos e1
+
+
+addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
+addTickHsExpr e@(HsVar _) = return e
+addTickHsExpr e@(HsIPVar _) = return e
+addTickHsExpr e@(HsOverLit _) = return e
+addTickHsExpr e@(HsLit _) = return e
+addTickHsExpr e@(HsLam matchgroup) =
+ liftM HsLam (addTickMatchGroup matchgroup)
+addTickHsExpr (HsApp e1 e2) =
+ liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
+addTickHsExpr (OpApp e1 e2 fix e3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsExpr' e2)
+ (return fix)
+ (addTickLHsExpr e3)
+addTickHsExpr ( NegApp e neg) =
+ liftM2 NegApp
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
+addTickHsExpr (SectionL e1 e2) =
+ liftM2 SectionL
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (SectionR e1 e2) =
+ liftM2 SectionR
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsCase e mgs) =
+ liftM2 HsCase
+ (addTickLHsExpr e)
+ (addTickMatchGroup mgs)
+addTickHsExpr (HsIf e1 e2 e3) =
+ liftM3 HsIf
+ (addBinTickLHsExpr CondBinBox e1)
+ (addTickLHsExprOptAlt True e2)
+ (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsLet binds e) =
+ liftM2 HsLet
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsExpr' e)
+addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
+ liftM4 HsDo
+ (return cxt)
+ (mapM (liftL (addTickStmt forQual)) stmts)
+ (addTickLHsExpr last_exp)
+ (return srcloc)
+ where
+ forQual = case cxt of
+ ListComp -> Just QualBinBox
+ _ -> Nothing
+addTickHsExpr (ExplicitList ty es) =
+ liftM2 ExplicitList
+ (return ty)
+ (mapM addTickLHsExpr es)
+addTickHsExpr (ExplicitPArr {}) = error "addTickHsExpr: ExplicitPArr "
+addTickHsExpr (ExplicitTuple es box) =
+ liftM2 ExplicitTuple
+ (mapM addTickLHsExpr es)
+ (return box)
+addTickHsExpr (RecordCon id ty rec_binds) =
+ liftM3 RecordCon
+ (return id)
+ (return ty)
+ (addTickHsRecordBinds rec_binds)
+addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
+ liftM4 RecordUpd
+ (addTickLHsExpr e)
+ (addTickHsRecordBinds rec_binds)
+ (return ty1)
+ (return ty2)
+addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
+addTickHsExpr (ExprWithTySigOut e ty) =
+ liftM2 ExprWithTySigOut
+ (addTickLHsExpr' e) -- No need to tick the inner expression
+ -- for expressions with signatures
+ (return ty)
+addTickHsExpr (ArithSeq ty arith_seq) =
+ liftM2 ArithSeq
+ (return ty)
+ (addTickArithSeqInfo arith_seq)
+addTickHsExpr (PArrSeq {}) = error "addTickHsExpr: PArrSeq "
+addTickHsExpr (HsSCC {}) = error "addTickHsExpr: HsSCC "
+addTickHsExpr (HsCoreAnn {}) = error "addTickHsExpr: HsCoreAnn "
+addTickHsExpr e@(HsBracket {}) = return e
+addTickHsExpr e@(HsBracketOut {}) = return e
+addTickHsExpr e@(HsSpliceE {}) = return e
+addTickHsExpr (HsProc pat cmdtop) =
+ liftM2 HsProc
+ (addTickLPat pat)
+ (liftL addTickHsCmdTop cmdtop)
+addTickHsExpr (HsWrap w e) =
+ liftM2 HsWrap
+ (return w)
+ (addTickHsExpr e) -- explicitly no tick on inside
+addTickHsExpr (HsArrApp {}) = error "addTickHsExpr: HsArrApp "
+addTickHsExpr (HsArrForm {}) = error "addTickHsExpr: HsArrForm"
+addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
+addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
+addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
+addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
+addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
+
+addTickHsExpr e@(HsType ty) = return e
+
+-- catch all, and give an error message.
+--addTickHsExpr e = error ("addTickLhsExpr: " ++ showSDoc (ppr e))
+
+
+addTickMatchGroup (MatchGroup matches ty) = do
+ let isOneOfMany = True -- AJG: for now
+ matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
+ return $ MatchGroup matches' ty
+
+addTickMatch :: Bool -> Match Id -> TM (Match Id)
+addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
+ gRHSs' <- addTickGRHSs isOneOfMany gRHSs
+ return $ Match pats opSig gRHSs'
+
+addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
+addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
+ guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
+ local_binds' <- addTickHsLocalBinds local_binds
+ return $ GRHSs guarded' local_binds'
+
+addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
+addTickGRHS isOneOfMany (GRHS stmts expr) = do
+ stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
+ expr' <- addTickLHsExprOptAlt isOneOfMany expr
+ return $ GRHS stmts' expr'
+
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt isGuard (BindStmt pat e bind fail) =
+ liftM4 BindStmt
+ (addTickLPat pat)
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan bind)
+ (addTickSyntaxExpr hpcSrcSpan fail)
+addTickStmt isGuard (ExprStmt e bind' ty) =
+ liftM3 ExprStmt
+ (addTick e)
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (return ty)
+ where
+ addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
+ | otherwise = addTickLHsExpr e
+
+addTickStmt isGuard (LetStmt binds) =
+ liftM LetStmt
+ (addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt pairs) =
+ liftM ParStmt (mapM process pairs)
+ where
+ process (stmts,ids) =
+ liftM2 (,)
+ (mapM (liftL (addTickStmt isGuard)) stmts)
+ (return ids)
+addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
+ liftM5 RecStmt
+ (mapM (liftL (addTickStmt isGuard)) stmts)
+ (return ids1)
+ (return ids2)
+ (return tys)
+ (addTickDictBinds dictbinds)
+
+addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
+addTickHsLocalBinds (HsValBinds binds) =
+ liftM HsValBinds
+ (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds binds) =
+ liftM HsIPBinds
+ (addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
+
+addTickHsValBinds (ValBindsOut binds sigs) =
+ liftM2 ValBindsOut
+ (mapM (\ (rec,binds') ->
+ liftM2 (,)
+ (return rec)
+ (addTickLHsBinds binds'))
+ binds)
+ (return sigs)
+
+addTickHsIPBinds (IPBinds ipbinds dictbinds) =
+ liftM2 IPBinds
+ (mapM (liftL addTickIPBind) ipbinds)
+ (addTickDictBinds dictbinds)
+
+addTickIPBind :: IPBind Id -> TM (IPBind Id)
+addTickIPBind (IPBind nm e) =
+ liftM2 IPBind
+ (return nm)
+ (addTickLHsExpr e)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
+addTickSyntaxExpr pos x = do
+ L _ x' <- addTickLHsExpr (L pos x)
+ return $ x'
+-- we do not walk into patterns.
+addTickLPat :: LPat Id -> TM (LPat Id)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
+ liftM4 HsCmdTop
+ (addTickLHsCmd cmd)
+ (return tys)
+ (return ty)
+ (return syntaxtable)
+
+addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
+addTickLHsCmd x = addTickLHsExpr x
+
+addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
+addTickDictBinds x = addTickLHsBinds x
+
+addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
+addTickHsRecordBinds pairs = mapM process pairs
+ where
+ process (ids,expr) =
+ liftM2 (,)
+ (return ids)
+ (addTickLHsExpr expr)
+
+addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
+addTickArithSeqInfo (From e1) =
+ liftM From
+ (addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+ liftM2 FromThen
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+ liftM2 FromTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+ liftM3 FromThenTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (addTickLHsExpr e3)
+\end{code}
+
+\begin{code}
+data TixFlags = TixFlags
+
+data TickTransState = TT { modName :: String
+ , declPath :: [String]
+ , tickBoxCount:: Int
+ , mixEntries :: [MixEntry]
+ }
+ deriving Show
+
+data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
+
+instance Monad TM where
+ return a = TM $ \ st -> (a,st)
+ (TM m) >>= k = TM $ \ st -> case m st of
+ (r1,st1) -> unTM (k r1) st1
+
+--addTick :: LHsExpr Id -> TM (LHsExpr Id)
+--addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
+ (r,st') -> (r,st' { declPath = declPath st })
+
+getPathEntry :: TM [String]
+getPathEntry = TM $ \ st -> (declPath st,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
+allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+ let me = (hpcPos,boxLabel)
+ c = tickBoxCount st
+ mes = mixEntries st
+ in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
+ , st {tickBoxCount=c+1,mixEntries=me:mes}
+ )
+allocTickBox boxLabel e = return id
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
+allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+ let me = (hpcPos,boxLabel)
+ c = tickBoxCount st
+ mes = mixEntries st
+ in ( Just c
+ , st {tickBoxCount=c+1,mixEntries=me:mes}
+ )
+allocATickBox boxLabel e = return Nothing
+
+allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+ let meT = (hpcPos,boxLabel True)
+ meF = (hpcPos,boxLabel False)
+ meE = (hpcPos,ExpBox)
+ c = tickBoxCount st
+ mes = mixEntries st
+ in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+ -- notice that F and T are reversed,
+ -- because we are building the list in
+ -- reverse...
+ , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
+ )
+
+allocBinTickBox boxLabel e = return e
+
+mkHpcPos :: SrcSpan -> Maybe HpcPos
+mkHpcPos pos
+ | not (isGoodSrcSpan pos) = Nothing
+ | start == end = Nothing -- no actual location
+ | otherwise = Just hpcPos
+ where
+ start = srcSpanStart pos
+ end = srcSpanEnd pos
+ hpcPos = toHpcPos ( srcLocLine start
+ , srcLocCol start + 1
+ , srcLocLine end
+ , srcLocCol end
+ )
+
+hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
+
+-- all newly allocated locations have an HPC tag on them, to help debuging
+hpcLoc :: e -> Located e
+hpcLoc = L hpcSrcSpan
+\end{code}
+
+
+\begin{code}
+---------------------------------------------------------------
+-- Datatypes and file-access routines for the per-module (.mix)
+-- indexes used by Hpc.
+-- Colin Runciman and Andy Gill, June 2006
+---------------------------------------------------------------
+
+-- a module index records the attributes of each tick-box that has
+-- been introduced in that module, accessed by tick-number position
+-- in the list
+
+data Mix = Mix
+ FilePath -- location of original file
+ Integer -- time (in seconds) of original file's last update, since 1970.
+ Int -- tab stop value
+ [MixEntry] -- entries
+ deriving (Show,Read)
+
+-- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
+-- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
+-- because if some other program also defined that instance, we will not be able to compile.
+
+type MixEntry = (HpcPos, BoxLabel)
+
+data BoxLabel = ExpBox
+ | AltBox
+ | TopLevelBox [String]
+ | LocalBox [String]
+ -- | UserBox (Maybe String)
+ | GuardBinBox Bool
+ | CondBinBox Bool
+ | QualBinBox Bool
+ -- | PreludeBinBox String Bool
+ -- | UserBinBox (Maybe String) Bool
+ deriving (Read, Show)
+
+mixCreate :: String -> String -> Mix -> IO ()
+mixCreate dirName modName mix =
+ writeFile (mixName dirName modName) (show mix)
+
+readMix :: FilePath -> String -> IO Mix
+readMix dirName modName = do
+ contents <- readFile (mixName dirName modName)
+ return (read contents)
+
+mixName :: FilePath -> String -> String
+mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
+
+getModificationTime' :: FilePath -> IO Integer
+getModificationTime' file = do
+ (TOD sec _) <- System.Directory.getModificationTime file
+ return $ sec
+
+data Tix = Tix [PixEntry] -- The number of tickboxes in each module
+ [TixEntry] -- The tick boxes
+ deriving (Read, Show,Eq)
+
+type TixEntry = Integer
+
+-- always read and write Tix from the current working directory.
+
+readTix :: String -> IO (Maybe Tix)
+readTix pname =
+ catch (do contents <- readFile $ tixName pname
+ return $ Just $ read contents)
+ (\ _ -> return $ Nothing)
+
+writeTix :: String -> Tix -> IO ()
+writeTix pname tix =
+ writeFile (tixName pname) (show tix)
+
+tixName :: String -> String
+tixName name = name ++ ".tix"
+
+-- a program index records module names and numbers of tick-boxes
+-- introduced in each module that has been transformed for coverage
+
+data Pix = Pix [PixEntry] deriving (Read, Show)
+
+type PixEntry = ( String -- module name
+ , Int -- number of boxes
+ )
+
+pixUpdate :: FilePath -> String -> String -> Int -> IO ()
+pixUpdate dirName progName modName boxCount = do
+ fileUpdate (pixName dirName progName) pixAssign (Pix [])
+ where
+ pixAssign :: Pix -> Pix
+ pixAssign (Pix pes) =
+ Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
+
+readPix :: FilePath -> String -> IO Pix
+readPix dirName pname = do
+ contents <- readFile (pixName dirName pname)
+ return (read contents)
+
+tickCount :: Pix -> Int
+tickCount (Pix mp) = sum $ map snd mp
+
+pixName :: FilePath -> String -> String
+pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
+
+-- updating a value stored in a file via read and show
+fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
+fileUpdate fname update init =
+ catch
+ (do
+ valueText <- readFile fname
+ ( case finite valueText of
+ True ->
+ writeFile fname (show (update (read valueText))) ))
+ (const (writeFile fname (show (update init))))
+
+finite :: [a] -> Bool
+finite [] = True
+finite (x:xs) = finite xs
+
+data HpcPos = P !Int !Int !Int !Int deriving (Eq)
+
+fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
+fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
+
+toHpcPos :: (Int,Int,Int,Int) -> HpcPos
+toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
+
+instance Show HpcPos where
+ show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
+
+instance Read HpcPos where
+ readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
+ where
+ (before,after) = span (/= ',') pos
+ (lhs,rhs) = case span (/= '-') before of
+ (lhs,'-':rhs) -> (lhs,rhs)
+ (lhs,"") -> (lhs,lhs)
+ (l1,':':c1) = span (/= ':') lhs
+ (l2,':':c2) = span (/= ':') rhs
+
+\end{code}
+
import Maybes
import FastString
import Util
+import Coverage
import Data.IORef
\end{code}
%************************************************************************
\begin{code}
-deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
+ mod_loc
tcg_env@(TcGblEnv { tcg_mod = mod,
tcg_src = hsc_src,
tcg_type_env = type_env,
; let auto_scc = mkAutoScc mod export_set
; mb_res <- case ghcMode dflags of
- JustTypecheck -> return (Just ([], [], NoStubs))
- _ -> initDs hsc_env mod rdr_env type_env $ do
- { core_prs <- dsTopLHsBinds auto_scc binds
+ JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo))
+ _ -> do (binds_cvr,ds_hpc_info)
+ <- if dopt Opt_Hpc dflags
+ then addCoverageTicksToBinds dflags mod mod_loc binds
+ else return (binds, noHpcInfo)
+ initDs hsc_env mod rdr_env type_env $ do
+ { core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
- ; return (all_prs, catMaybes ds_rules, ds_fords)
+ ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
}
; case mb_res of {
Nothing -> return Nothing ;
- Just (all_prs, ds_rules, ds_fords) -> do
+ Just (all_prs, ds_rules, ds_fords,ds_hpc_info) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
mg_fam_insts = fam_insts,
mg_rules = ds_rules,
mg_binds = ds_binds,
- mg_foreign = ds_fords }
-
+ mg_foreign = ds_fords,
+ mg_hpc_info = ds_hpc_info }
; return (Just mod_guts)
}}}
addDictScc var core_expr `thenDs` \ core_expr' ->
returnDs ((var, core_expr') : rest)
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
- dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs ->
+ mkOptTickBox tick body `thenDs` \ body' ->
+ dsCoercion co_fn (return (mkLams args body')) `thenDs` \ rhs ->
returnDs ((fun,rhs) : rest)
dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
-- below. Then pattern-match would fail. Urk.)
putSrcSpanDs loc $
case bind of
- FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
-> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
ASSERT( isIdHsWrapper co_fn )
- returnDs (bindNonRec fun rhs body_w_exports)
+ mkOptTickBox tick rhs `thenDs` \ rhs' ->
+ returnDs (bindNonRec fun rhs' body_w_exports)
PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-> -- let C x# y# = rhs in body
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
\end{code}
+Hpc Support
+
+\begin{code}
+dsExpr (HsTick ix e) = do
+ e' <- dsLExpr e
+ mkTickBox ix e'
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+dsExpr (HsBinTick ixT ixF e) = do
+ e2 <- dsLExpr e
+ do { ASSERT(exprType e2 `coreEqType` boolTy)
+ mkBinaryTickBox ixT ixF e2
+ }
+\end{code}
\begin{code}
dsSyntaxTable, lookupEvidence,
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+ mkTickBox, mkOptTickBox, mkBinaryTickBox
) where
#include "HsVersions.h"
ty = exprType expr
\end{code}
-
+\begin{code}
+mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
+mkOptTickBox Nothing e = return e
+mkOptTickBox (Just ix) e = mkTickBox ix e
+
+mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
+mkTickBox ix e = do
+ mod <- getModuleDs
+ return $ Note (TickBox mod ix) e
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+ mod <- getModuleDs
+ return $ Note (BinaryTickBox mod ixT ixF) e
+\end{code}
\ No newline at end of file
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
- bind_fvs :: NameSet -- After the renamer, this contains a superset of the
+ bind_fvs :: NameSet, -- After the renamer, this contains a superset of the
-- Names of the other binders in this binding group that
-- are free in the RHS of the defn
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
+
+ fun_tick :: Maybe Int -- This is the (optional) module-local tick number.
}
| PatBind { -- The pattern is never a simple variable;
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
+ppr_monobind (FunBind { fun_id = fun,
+ fun_matches = matches,
+ fun_tick = tick }) =
+ (case tick of
+ Nothing -> empty
+ Just t -> text "-- tick id = " <> ppr t
+ ) $$ pprFunBind (unLoc fun) matches
-- ToDo: print infix if appropriate
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
-- always has an empty stack
---------------------------------------
+ -- Hpc Support
+
+ | HsTick
+ Int -- module-local tick number
+ (LHsExpr id) -- sub-expression
+
+ | HsBinTick
+ Int -- module-local tick number for True
+ Int -- module-local tick number for False
+ (LHsExpr id) -- sub-expression
+
+ ---------------------------------------
-- The following are commands, not expressions proper
| HsArrApp -- Arrow tail, or arrow application (f -< arg)
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
+ppr_expr (HsTick tickId exp)
+ = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ = hcat [ptext SLIT("bintick<"),
+ ppr tickIdTrue,
+ ptext SLIT(","),
+ ppr tickIdFalse,
+ ptext SLIT(">("),
+ ppr exp,ptext SLIT(")")]
+
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
mkFunBind :: Located id -> [LMatch id] -> HsBind id
-- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
- fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
+ fun_tick = Nothing }
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
put_ bh (IfaceCoreNote s) = do
putByte bh 4
put_ bh s
+ put_ bh (IfaceTickBox m n) = do
+ putByte bh 5
+ put_ bh m
+ put_ bh n
+ put_ bh (IfaceBinaryTickBox m t e) = do
+ putByte bh 6
+ put_ bh m
+ put_ bh t
+ put_ bh e
get bh = do
h <- getByte bh
case h of
3 -> do return IfaceInlineMe
4 -> do ac <- get bh
return (IfaceCoreNote ac)
-
+ 5 -> do m <- get bh
+ n <- get bh
+ return (IfaceTickBox m n)
+ 6 -> do m <- get bh
+ t <- get bh
+ e <- get bh
+ return (IfaceBinaryTickBox m t e)
-------------------------------------------------------------------------
-- IfaceDecl and friends
import BasicTypes
import Outputable
import FastString
+import Module
import Data.List
import Data.Maybe
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
| IfaceCoreNote String
+ | IfaceTickBox Module Int
+ | IfaceBinaryTickBox Module Int Int
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- Note: FastString, not IfaceBndr (and same with the case binder)
ppr (IfaceSCC cc) = pprCostCentreCore cc
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+ ppr (IfaceTickBox m n) = ptext SLIT("__tick_box") <+> pprModule m <+> text (show n)
+ ppr (IfaceBinaryTickBox m t e)
+ = ptext SLIT("__binary_tick_box")
+ <+> pprModule m
+ <+> text (show t)
+ <+> text (show e)
+
instance Outputable IfaceConAlt where
ppr IfaceDefault = text "DEFAULT"
eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
+eq_ifaceNote env (IfaceTickBox m1 n1) (IfaceTickBox m2 n2) = bool (m1==m2 && n1==n2)
+eq_ifaceNote env (IfaceBinaryTickBox m1 t1 e1) (IfaceBinaryTickBox m2 t2 e2) = bool (m1==m2 && t1==t2 && e1 == e2)
eq_ifaceNote env _ _ = NotEqual
\end{code}
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
+toIfaceNote (TickBox m n) = IfaceTickBox m n
+toIfaceNote (BinaryTickBox m t e)
+ = IfaceBinaryTickBox m t e
---------------------
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
IfaceInlineMe -> returnM (Note InlineMe expr')
IfaceSCC cc -> returnM (Note (SCC cc) expr')
IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
+ IfaceTickBox m n -> returnM (Note (TickBox m n) expr')
+ IfaceBinaryTickBox m t e -> returnM (Note (BinaryTickBox m t e) expr')
-------------------------
tcIfaceAlt _ (IfaceDefault, names, rhs)
| Opt_D_dump_splices
| Opt_D_dump_BCOs
| Opt_D_dump_vect
+ | Opt_D_dump_hpc
| Opt_D_source_stats
| Opt_D_verbose_core2core
| Opt_D_verbose_stg2stg
| Opt_HideAllPackages
| Opt_PrintBindResult
| Opt_Haddock
+ | Opt_Hpc
+ | Opt_Hpc_Trace
-- keeping stuff
| Opt_KeepHiDiffs
ghcUsagePath :: FilePath, -- Filled in by SysTools
ghciUsagePath :: FilePath, -- ditto
+ hpcDir :: String, -- ^ path to store the .mix files
+
-- options for particular phases
opt_L :: [String],
opt_P :: [String],
cmdlineFrameworks = [],
tmpDir = cDEFAULT_TMPDIR,
+ hpcDir = ".hpc",
+
opt_L = [],
opt_P = [],
opt_F = [],
, ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain))
, ( "main-is" , SepArg setMainIs )
, ( "haddock" , NoArg (setDynFlag Opt_Haddock) )
+ , ( "hpcdir" , SepArg setOptHpcDir )
------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
, ( "recomp" , NoArg (unSetDynFlag Opt_ForceRecomp) )
, ( "ddump-hi", setDumpFlag Opt_D_dump_hi)
, ( "ddump-minimal-imports", NoArg (setDynFlag Opt_D_dump_minimal_imports))
, ( "ddump-vect", setDumpFlag Opt_D_dump_vect)
+ , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc)
+
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting))
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting))
, ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting))
( "excess-precision", Opt_ExcessPrecision ),
( "asm-mangling", Opt_DoAsmMangling ),
( "print-bind-result", Opt_PrintBindResult ),
- ( "force-recomp", Opt_ForceRecomp )
+ ( "force-recomp", Opt_ForceRecomp ),
+ ( "hpc", Opt_Hpc ),
+ ( "hpc-tracer", Opt_Hpc )
]
#endif
-----------------------------------------------------------------------------
+-- Hpc stuff
+
+setOptHpcDir :: String -> DynP ()
+setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg}
+
+-----------------------------------------------------------------------------
-- Via-C compilation stuff
machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations
-------------------
-- DESUGAR
-------------------
- -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result
+ -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result
--------------------------------------------------------------
-- Simplifiers
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
- cg_dep_pkgs = dependencies } = cgguts
+ cg_dep_pkgs = dependencies,
+ cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
abstractC <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
foreign_stubs dir_imps cost_centre_info
- stg_binds
+ stg_binds hpc_info
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
-- Linker stuff
Linkable(..), isObjectLinkable,
Unlinked(..), CompiledByteCode,
- isObject, nameOfObject, isInterpretable, byteCodeOfObject
+ isObject, nameOfObject, isInterpretable, byteCodeOfObject,
+ HpcInfo, noHpcInfo
) where
#include "HsVersions.h"
mg_fam_insts :: ![FamInst], -- Instances
mg_rules :: ![CoreRule], -- Rules from this module
mg_binds :: ![CoreBind], -- Bindings for this module
- mg_foreign :: !ForeignStubs
+ mg_foreign :: !ForeignStubs,
+ mg_hpc_info :: !HpcInfo -- info about coverage tick boxes
}
-- The ModGuts takes on several slightly different forms:
-- initialisation code
cg_foreign :: !ForeignStubs,
- cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen
+ cg_dep_pkgs :: ![PackageId], -- Used to generate #includes for C code gen
+ cg_hpc_info :: !HpcInfo -- info about coverage tick boxes
}
-----------------------------------
%************************************************************************
%* *
+\subsection{Hpc Support}
+%* *
+%************************************************************************
+
+\begin{code}
+type HpcInfo = Int -- just the number of ticks in a module
+
+noHpcInfo :: HpcInfo
+noHpcInfo = 0 -- default = 0
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Linkable stuff}
%* *
%************************************************************************
mg_binds = binds,
mg_rules = imp_rules,
mg_dir_imps = dir_imps, mg_deps = deps,
- mg_foreign = foreign_stubs })
+ mg_foreign = foreign_stubs,
+ mg_hpc_info = hpc_info })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy Core"
cg_binds = all_tidy_binds,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
- cg_dep_pkgs = dep_pkgs deps },
+ cg_dep_pkgs = dep_pkgs deps,
+ cg_hpc_info = hpc_info },
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
- | is_caf || mentions_cafs = MayHaveCafRefs
+ | is_caf || mentions_cafs || is_tick
+ = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+ is_tick = case expr of
+ Note (TickBox {}) _ -> True
+ Note (BinaryTickBox {}) _ -> True
+ _ -> False
+
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
- fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
= do_let b e `thenMM` \ (b,e) ->
returnMM (StgLetNoEscape lvs1 lvs2 b e)
+ do_expr (StgTick m n expr)
+ = do_expr expr `thenMM` \ expr' ->
+ returnMM (StgTick m n expr')
+
#ifdef DEBUG
do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
#endif
; checkPrecMatch inf plain_name matches'
; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches',
- bind_fvs = trim fvs, fun_co_fn = idHsWrapper }),
+ bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }),
[plain_name], fvs)
}
\end{code}
= -- Ditto... don't float anything into an INLINE expression
mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote note@(TickBox {}) expr)
+ = -- Wimp out for now
+ mkCoLets' to_drop (Note note (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote note@(BinaryTickBox {}) expr)
+ = -- Wimp out for now
+ mkCoLets' to_drop (Note note (fiExpr [] expr))
+
fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr)
\end{code}
simplNote env (CoreNote s) e cont
= simplExpr env e `thenSmpl` \ e' ->
rebuild env (Note (CoreNote s) e') cont
+
+simplNote env note@(TickBox {}) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note note e') cont
+
+simplNote env note@(BinaryTickBox {}) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note note e') cont
\end{code}
srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
+srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
+
srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
= StgCase expr' live1 live2 uniq srt' alt_type alts'
where
statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgSCC l e) = statExpr e
+statExpr (StgTick m n e) = statExpr e
statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
= statBinding False{-not top-level-} binds `combineSE`
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
returnLne (StgSCC cc expr2, fvs, escs) )
+coreToStgExpr (Note (TickBox m n) expr)
+ = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
+ returnLne (StgTick m n expr2, fvs, escs) )
+
+-- BinaryTickBox'es are are removed by the CorePrep pass.
+
+coreToStgExpr expr@(Note (BinaryTickBox m t e) _)
+ = pprPanic "coreToStgExpr: " (ppr expr)
+
coreToStgExpr (Note other_note expr)
= coreToStgExpr expr
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e)
+ go bs e@(Note (TickBox {}) _) = (reverse bs, e)
+ go bs e@(Note (BinaryTickBox {}) _) = (reverse bs, e)
go bs (Cast e co) = go bs e
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
go (Var v) as = (v, as)
go (App f a) as = go f (a:as)
go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note (BinaryTickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
go (Cast e co) as = go e as
go (Note n e) as = go e as
go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
import Unique ( Unique )
import Bitmap
import StaticFlags ( opt_SccProfilingOn )
+import Module ( Module, pprModule )
\end{code}
%************************************************************************
| StgSCC
CostCentre -- label of SCC expression
(GenStgExpr bndr occ) -- scc expression
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@GenStgExpr@: @hpc@ expressions}
+%* *
+%************************************************************************
+
+Finally for @scc@ expressions we introduce a new STG construct.
+
+\begin{code}
+ | StgTick
+ Module -- the module of the source of this tick
+ Int -- tick number
+ (GenStgExpr bndr occ) -- sub expression
-- end of GenStgExpr
\end{code}
= sep [ hsep [ptext SLIT("_scc_"), ppr cc],
pprStgExpr expr ]
+pprStgExpr (StgTick m n expr)
+ = sep [ hsep [ptext SLIT("_tick_"), pprModule m,text (show n)],
+ pprStgExpr expr ]
+
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
; let mono_id = mkLocalId mono_name zonked_rhs_ty
; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
fun_matches = matches', bind_fvs = fvs,
- fun_co_fn = co_fn })),
+ fun_co_fn = co_fn, fun_tick = Nothing })),
[(name, Nothing, mono_id)]) }
tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
- bind_fvs = placeHolderNames, fun_co_fn = co_fn }
+ bind_fvs = placeHolderNames, fun_co_fn = co_fn,
+ fun_tick = Nothing }
; return (unitBag (L b_loc fun_bind'),
[(name, Just tc_sig, mono_id)]) }
= do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches
(idType mono_id)
; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
- bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
+ bind_fvs = placeHolderNames, fun_co_fn = co_fn,
+ fun_tick = Nothing }) }
tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
= do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo
} } ;
tcCoreDump mod_guts ;
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)_hpc?${T_POST_LBL}$/o ) {
+ # hpc shares tick boxes across modules
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'data';
+ $chksymb[$i] = '';
+
} elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
extern void hs_free_stable_ptr (HsStablePtr sp);
extern void hs_free_fun_ptr (HsFunPtr fp);
+extern void hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr);
+
/* -------------------------------------------------------------------------- */
#ifdef __cplusplus
--- /dev/null
+/*
+ * (c)2006 Galois Connections, Inc.
+ */
+
+// #include "HsFFI.h"
+
+#include <stdio.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include "HsFFI.h"
+#include "Hpc.h"
+
+/* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
+ * inside GHC.
+ *
+ */
+
+#define DEBUG_HPC 0
+
+static int hpc_inited = 0; // Have you started this component?
+static FILE *tixFile; // file being read/written
+static int tix_ch; // current char
+
+typedef struct _Info {
+ char *modName; // name of module
+ int tickCount; // number of ticks
+ int tickOffset; // offset into a single large .tix Array
+ StgWord64 *tixArr; // tix Array from the program execution (local for this module)
+ struct _Info *next;
+} Info;
+
+Info *modules = 0;
+Info *nextModule = 0;
+StgWord64 *tixBoxes = 0; // local copy of tixBoxes array, from file.
+int totalTixes = 0; // total number of tix boxes.
+
+
+
+static char *tixFilename = "Main.tix";
+
+static void failure(char *msg) {
+ printf("Hpc failure: %s\n",msg);
+ printf("(perhaps remove .tix file?)\n");
+ exit(-1);
+}
+
+
+static int init_open(char *filename)
+{
+ tixFile = fopen(filename,"r");
+ if (tixFile == 0) {
+ return 0;
+ }
+ tix_ch = getc(tixFile);
+ return 1;
+}
+
+static void expect(char c) {
+ if (tix_ch != c) {
+ printf("Hpc: parse failed (%c,%c)\n",tix_ch,c);
+ exit(-1);
+ }
+ tix_ch = getc(tixFile);
+}
+
+static void ws(void) {
+ while (tix_ch == ' ') {
+ tix_ch = getc(tixFile);
+ }
+}
+
+static char *expectString(void) {
+ char tmp[256], *res;
+ int tmp_ix = 0;
+ expect('"');
+ while (tix_ch != '"') {
+ tmp[tmp_ix++] = tix_ch;
+ tix_ch = getc(tixFile);
+ }
+ tmp[tmp_ix++] = 0;
+ expect('"');
+ res = malloc(tmp_ix);
+ strcpy(res,tmp);
+ return res;
+}
+
+static StgWord64 expectWord64(void) {
+ StgWord64 tmp = 0;
+ while (isdigit(tix_ch)) {
+ tmp = tmp * 10 + (tix_ch -'0');
+ tix_ch = getc(tixFile);
+ }
+ return tmp;
+}
+
+static void hpc_init(void) {
+ int i;
+ Info *tmpModule;
+
+ if (hpc_inited != 0) {
+ return;
+ }
+ hpc_inited = 1;
+
+ if (init_open(tixFilename)) {
+ totalTixes = 0;
+
+ ws();
+ expect('T');
+ expect('i');
+ expect('x');
+ ws();
+ expectWord64();
+ ws();
+ expect('[');
+ ws();
+ while(tix_ch != ']') {
+ tmpModule = (Info *)calloc(1,sizeof(Info));
+ expect('(');
+ ws();
+ tmpModule -> modName = expectString();
+ ws();
+ expect(',');
+ ws();
+ tmpModule -> tickCount = (int)expectWord64();
+ ws();
+ expect(')');
+ ws();
+
+ tmpModule -> tickOffset = totalTixes;
+ totalTixes += tmpModule -> tickCount;
+
+ tmpModule -> tixArr = 0;
+
+ if (!modules) {
+ modules = tmpModule;
+ } else {
+ nextModule->next=tmpModule;
+ }
+ nextModule=tmpModule;
+
+ if (tix_ch == ',') {
+ expect(',');
+ ws();
+ }}
+ expect(']');
+ ws();
+ tixBoxes = (StgWord64 *)calloc(totalTixes,sizeof(StgWord64));
+
+ expect('[');
+ for(i = 0;i < totalTixes;i++) {
+ if (i != 0) {
+ expect(',');
+ ws();
+ }
+ tixBoxes[i] = expectWord64();
+ ws();
+ }
+ expect(']');
+
+ fclose(tixFile);
+ }
+}
+
+/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory.
+ * This memory can be uninitized, because we will initialize it with either the contents
+ * of the tix file, or all zeros.
+ */
+
+void
+hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr) {
+ Info *tmpModule, *lastModule;
+ int i;
+
+#if DEBUG_HPC
+ printf("hs_hpc_module(%s,%d)\n",modName,modCount);
+#endif
+
+ hpc_init();
+
+ tmpModule = modules;
+ lastModule = 0;
+
+ for(;tmpModule != 0;tmpModule = tmpModule->next) {
+ if (!strcmp(tmpModule->modName,modName)) {
+ if (tmpModule->tickCount != modCount) {
+ failure("inconsistent number of tick boxes");
+ }
+ assert(tmpModule->tixArr == 0);
+ assert(tixBoxes != 0);
+ tmpModule->tixArr = tixArr;
+ for(i=0;i < modCount;i++) {
+ tixArr[i] = tixBoxes[i + tmpModule->tickOffset];
+ }
+ return;
+ }
+ lastModule = tmpModule;
+ }
+ // Did not find entry so add one on.
+ tmpModule = (Info *)calloc(1,sizeof(Info));
+ tmpModule->modName = modName;
+ tmpModule->tickCount = modCount;
+ if (lastModule) {
+ tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
+ } else {
+ tmpModule->tickOffset = 0;
+ }
+ tmpModule->tixArr = tixArr;
+ for(i=0;i < modCount;i++) {
+ tixArr[i] = 0;
+ }
+ tmpModule->next = 0;
+
+ if (!modules) {
+ modules = tmpModule;
+ } else {
+ lastModule->next=tmpModule;
+ }
+
+#if DEBUG_HPC
+ printf("end: hs_hpc_module\n");
+#endif
+}
+
+/* This is called after all the modules have registered their local tixboxes,
+ * and does a sanity check: are we good to go?
+ */
+
+void
+startupHpc(void) {
+ Info *tmpModule;
+#if DEBUG_HPC
+ printf("startupHpc\n");
+#endif
+
+ if (hpc_inited == 0) {
+ return;
+ }
+
+ tmpModule = modules;
+
+ if (tixBoxes) {
+ for(;tmpModule != 0;tmpModule = tmpModule->next) {
+ if (!tmpModule->tixArr) {
+ fprintf(stderr,"error: module %s did not register any hpc tick data\n",
+ tmpModule->modName);
+ fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
+ exit(-1);
+ }
+ }
+ }
+}
+
+/* Called at the end of execution, to write out the Hpc *.tix file
+ * for this exection. Safe to call, even if coverage is not used.
+ */
+void
+exitHpc(void) {
+ Info *tmpModule;
+ int i, comma;
+
+#if DEBUG_HPC
+ printf("exitHpc\n");
+#endif
+
+ if (hpc_inited == 0) {
+ return;
+ }
+
+ FILE *f = fopen(tixFilename,"w");
+
+ comma = 0;
+
+ fprintf(f,"Tix 0 [");
+ tmpModule = modules;
+ for(;tmpModule != 0;tmpModule = tmpModule->next) {
+ if (comma) {
+ fprintf(f,",");
+ } else {
+ comma = 1;
+ }
+ fprintf(f,"(\"%s\",%d)",
+ tmpModule->modName,
+ tmpModule->tickCount);
+#if DEBUG_HPC
+ fprintf(stderr,"%s: %d (offset=%d)\n",
+ tmpModule->modName,
+ tmpModule->tickCount,
+ tmpModule->tickOffset);
+#endif
+ }
+ fprintf(f,"] [");
+
+ comma = 0;
+ tmpModule = modules;
+ for(;tmpModule != 0;tmpModule = tmpModule->next) {
+ if (!tmpModule->tixArr) {
+ fprintf(stderr,"warning: module %s did not register any hpc tick data\n",
+ tmpModule->modName);
+ }
+
+ for(i = 0;i < tmpModule->tickCount;i++) {
+ if (comma) {
+ fprintf(f,",");
+ } else {
+ comma = 1;
+ }
+
+ if (tmpModule->tixArr) {
+ fprintf(f,"%lld",tmpModule->tixArr[i]);
+ } else {
+ fprintf(f,"0");
+ }
+
+ }
+ }
+
+ fprintf(f,"]\n");
+ fclose(f);
+
+}
+
--- /dev/null
+#ifndef HPC_H
+#define HPC_H
+
+extern void startupHpc(void);
+extern void exitHpc(void);
+
+#endif /* HPC_H */
+
+
+
freeGroup_lock(bd);
+ startupHpc();
+
#if defined(PROFILING) || defined(DEBUG)
// This must be done after module initialisation.
// ToDo: make this work in the presence of multiple hs_add_root()s.
/* stop timing the shutdown, we're about to print stats */
stat_endExit();
+ /* shutdown the hpc support (if needed) */
+ exitHpc();
+
// clean up things from the storage manager's point of view.
// also outputs the stats (+RTS -s) info.
exitStorage();
projects / ghc-hetmet.git / commitdiff