From d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048 Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Tue, 24 Oct 2006 21:29:07 +0000 Subject: [PATCH] Haskell Program Coverage This large checkin is the new ghc version of Haskell Program Coverage, an expression-level coverage tool for Haskell. Parts: - Hpc.[ch] - small runtime support for Hpc; reading/writing *.tix files. - Coverage.lhs - Annotates the HsSyn with coverage tickboxes. - New Note's in Core, - TickBox -- ticked on entry to sub-expression - BinaryTickBox -- ticked on exit to sub-expression, depending -- on the boolean result. - New Stg level TickBox (no BinaryTickBoxes, though) You can run the coverage tool with -fhpc at compile time. Main must be compiled with -fhpc. --- compiler/cmm/CLabel.hs | 21 ++ compiler/codeGen/CgExpr.lhs | 11 + compiler/codeGen/CgHpc.hs | 71 ++++ compiler/codeGen/CodeGen.lhs | 53 ++- compiler/coreSyn/CorePrep.lhs | 35 ++ compiler/coreSyn/CoreSyn.lhs | 9 + compiler/coreSyn/CoreUtils.lhs | 15 + compiler/coreSyn/PprCore.lhs | 16 + compiler/deSugar/Coverage.lhs | 647 +++++++++++++++++++++++++++++++++++++ compiler/deSugar/Desugar.lhs | 22 +- compiler/deSugar/DsBinds.lhs | 5 +- compiler/deSugar/DsExpr.lhs | 25 +- compiler/deSugar/DsUtils.lhs | 19 +- compiler/hsSyn/HsBinds.lhs | 12 +- compiler/hsSyn/HsExpr.lhs | 22 ++ compiler/hsSyn/HsUtils.lhs | 3 +- compiler/iface/BinIface.hs | 17 +- compiler/iface/IfaceSyn.lhs | 12 + compiler/iface/MkIface.lhs | 3 + compiler/iface/TcIface.lhs | 2 + compiler/main/DynFlags.hs | 20 +- compiler/main/HscMain.lhs | 7 +- compiler/main/HscTypes.lhs | 22 +- compiler/main/TidyPgm.lhs | 14 +- compiler/parser/RdrHsSyn.lhs | 2 +- compiler/profiling/SCCfinal.lhs | 4 + compiler/rename/RnBinds.lhs | 2 +- compiler/simplCore/FloatIn.lhs | 7 + compiler/simplCore/Simplify.lhs | 8 + compiler/simplStg/SRT.lhs | 2 + compiler/simplStg/StgStats.lhs | 1 + compiler/stgSyn/CoreToStg.lhs | 13 + compiler/stgSyn/StgSyn.lhs | 20 ++ compiler/typecheck/TcBinds.lhs | 8 +- compiler/typecheck/TcRnDriver.lhs | 3 +- driver/mangler/ghc-asm.lprl | 6 + includes/HsFFI.h | 2 + rts/Hpc.c | 324 +++++++++++++++++++ rts/Hpc.h | 10 + rts/RtsStartup.c | 5 + 40 files changed, 1450 insertions(+), 50 deletions(-) create mode 100644 compiler/codeGen/CgHpc.hs create mode 100644 compiler/deSugar/Coverage.lhs create mode 100644 rts/Hpc.c create mode 100644 rts/Hpc.h diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index f6c5148..54abe23 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -93,6 +93,9 @@ module CLabel ( mkPicBaseLabel, mkDeadStripPreventer, + mkHpcTicksLabel, + mkHpcModuleNameLabel, + infoLblToEntryLbl, entryLblToInfoLbl, needsCDecl, isAsmTemp, externallyVisibleCLabel, CLabelType(..), labelType, labelDynamic, @@ -205,6 +208,9 @@ data CLabel | 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 @@ -402,6 +408,11 @@ mkRtsApFastLabel str = RtsLabel (RtsApFast str) mkRtsSlowTickyCtrLabel :: String -> CLabel mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) + -- Coverage + +mkHpcTicksLabel = HpcTicksLabel +mkHpcModuleNameLabel = HpcModuleNameLabel + -- Dynamic linking mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel @@ -473,6 +484,8 @@ needsCDecl (RtsLabel _) = False needsCDecl (ForeignLabel _ _ _) = False needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True +needsCDecl (HpcTicksLabel _) = True +needsCDecl HpcModuleNameLabel = False -- Whether the label is an assembler temporary: @@ -501,6 +514,8 @@ externallyVisibleCLabel (DynIdLabel name _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel HpcModuleNameLabel = False -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -761,6 +776,12 @@ pprCLbl (ModuleInitLabel mod way _) 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 diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index fff2b3d..8834078 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -26,6 +26,7 @@ import CgTailCall import CgInfoTbls import CgForeignCall import CgPrimOp +import CgHpc import CgUtils import ClosureInfo import Cmm @@ -252,6 +253,16 @@ cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr \end{code} %******************************************************** +%* * +%* Hpc Tick Boxes * +%* * +%******************************************************** + +\begin{code} +cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr +\end{code} + +%******************************************************** %* * %* Non-top-level bindings * %* * diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs new file mode 100644 index 0000000..53d81c9 --- /dev/null +++ b/compiler/codeGen/CgHpc.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- +-- 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" + diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 2c4ea5c..3b7fc0a 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -25,6 +25,7 @@ import CgBindery import CgClosure import CgCon import CgUtils +import CgHpc import CLabel import Cmm @@ -60,10 +61,11 @@ codeGen :: DynFlags -> [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 @@ -77,7 +79,7 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods ; 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 @@ -142,17 +144,24 @@ mkModuleInit -> 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) } @@ -161,8 +170,6 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe 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 @@ -172,8 +179,12 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe -- 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 @@ -196,10 +207,15 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe { -- 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 @@ -207,6 +223,11 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe 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 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 3b8f577..fb31e45 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -33,6 +33,7 @@ import ErrUtils import DynFlags import Util import Outputable +import TysWiredIn \end{code} -- --------------------------------------------------------------------------- @@ -333,6 +334,8 @@ exprIsTrivial (Type _) = True 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 @@ -380,6 +383,23 @@ corePrepExprFloat env (Note n@(SCC _) expr) 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') @@ -395,6 +415,21 @@ corePrepExprFloat env expr@(Lam _ _) 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) -> diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 3c98f28..3f74dc5 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -60,6 +60,7 @@ import DataCon 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) @@ -132,6 +133,11 @@ data Note | 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 @@ -615,6 +621,9 @@ seqExprs [] = () 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` () diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index ffbdb50..d82acb9 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -800,6 +800,14 @@ exprIsConApp_maybe (Cast expr co) 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 @@ -1184,6 +1192,9 @@ exprArity e = go e 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 @@ -1301,6 +1312,8 @@ exprSize (Type t) = seqType t `seq` 1 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 @@ -1446,6 +1459,8 @@ rhsIsStatic this_pkg rhs = is_static False rhs 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 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 08fbdc4..cb79cb4 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -33,6 +33,7 @@ import BasicTypes import Util import Outputable import FastString +import Module \end{code} %************************************************************************ @@ -212,6 +213,21 @@ ppr_expr add_par (Note (SCC cc) expr) 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)], diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs new file mode 100644 index 0000000..9a53b2b --- /dev/null +++ b/compiler/deSugar/Coverage.lhs @@ -0,0 +1,647 @@ +% +% (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 -- 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} + diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index ab4ee74..2e5b1e1 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -42,6 +42,7 @@ import SrcLoc import Maybes import FastString import Util +import Coverage import Data.IORef \end{code} @@ -53,10 +54,11 @@ import Data.IORef %************************************************************************ \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, @@ -81,18 +83,22 @@ deSugar hsc_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 @@ -160,8 +166,8 @@ deSugar hsc_env 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) }}} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 8ed9719..27d4147 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -89,9 +89,10 @@ dsHsBind auto_scc rest (VarBind var expr) 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 }) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4a5521c..2bb2cc4 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -111,11 +111,12 @@ ds_val_bind (NonRecursive, hsbinds) body -- 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 @@ -570,6 +571,26 @@ dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) 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} diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 0552c2b..868a894 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -33,7 +33,8 @@ module DsUtils ( dsSyntaxTable, lookupEvidence, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkTickBox, mkOptTickBox, mkBinaryTickBox ) where #include "HsVersions.h" @@ -880,4 +881,18 @@ mkFailurePair expr 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 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index ebac06f..41097d8 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -87,11 +87,13 @@ data HsBind id -- 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; @@ -238,7 +240,13 @@ ppr_monobind :: OutputableBndr id => HsBind id -> SDoc 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, diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 2360337..9bcd06e 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -202,6 +202,18 @@ data HsExpr id -- 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) @@ -391,6 +403,16 @@ ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps 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) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index be4431d..51c6a19 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -225,7 +225,8 @@ nlHsFunTy a b = noLoc (HsFunTy a b) 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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ebb26c7..72ea80d 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1002,6 +1002,15 @@ instance Binary IfaceNote where 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 @@ -1010,7 +1019,13 @@ instance Binary IfaceNote where 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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 7efa029..55cd6d1 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -41,6 +41,7 @@ import SrcLoc import BasicTypes import Outputable import FastString +import Module import Data.List import Data.Maybe @@ -209,6 +210,8 @@ data IfaceExpr 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) @@ -482,6 +485,13 @@ instance Outputable IfaceNote where 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" @@ -749,6 +759,8 @@ eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq 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} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7518111..f7cb28a 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1240,6 +1240,9 @@ toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) 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) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 4232195..6c60af8 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -686,6 +686,8 @@ tcIfaceExpr (IfaceNote note expr) 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) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 20376f0..53fa11a 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -121,6 +121,7 @@ data DynFlag | 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 @@ -198,6 +199,8 @@ data DynFlag | Opt_HideAllPackages | Opt_PrintBindResult | Opt_Haddock + | Opt_Hpc + | Opt_Hpc_Trace -- keeping stuff | Opt_KeepHiDiffs @@ -255,6 +258,8 @@ data DynFlags = DynFlags { 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], @@ -392,6 +397,8 @@ defaultDynFlags = cmdlineFrameworks = [], tmpDir = cDEFAULT_TMPDIR, + hpcDir = ".hpc", + opt_L = [], opt_P = [], opt_F = [], @@ -875,6 +882,7 @@ dynamic_flags = [ , ( "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) ) @@ -938,6 +946,8 @@ dynamic_flags = [ , ( "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)) @@ -1041,7 +1051,9 @@ fFlags = [ ( "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 ) ] @@ -1244,6 +1256,12 @@ setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir } #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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 31995f0..6c09b97 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -466,7 +466,7 @@ hscFileFrontEnd = ------------------- -- DESUGAR ------------------- - -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result + -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result -------------------------------------------------------------- -- Simplifiers @@ -583,7 +583,8 @@ hscCompile cgguts 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 @@ -603,7 +604,7 @@ hscCompile cgguts 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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index c5483b9..4dc7894 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -58,7 +58,8 @@ module HscTypes ( -- Linker stuff Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + HpcInfo, noHpcInfo ) where #include "HsVersions.h" @@ -480,7 +481,8 @@ data ModGuts 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: @@ -517,7 +519,8 @@ data CgGuts -- 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 } ----------------------------------- @@ -1139,6 +1142,19 @@ showModMsg target recomp mod_summary %************************************************************************ %* * +\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} %* * %************************************************************************ diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b95d4d3..331d921 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -239,7 +239,8 @@ tidyProgram hsc_env 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" @@ -290,7 +291,8 @@ tidyProgram hsc_env 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, @@ -789,11 +791,17 @@ CAF list to keep track of non-collectable CAFs. \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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 28f8fcb..da31d06 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -757,7 +757,7 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id -- 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 diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 8e02892..d27a3a0 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -195,6 +195,10 @@ stgMassageForProfiling this_pkg mod_name us stg_binds = 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 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index ecd3b3d..ad2a6b3 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -398,7 +398,7 @@ rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches ; 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} diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index e32a8ea..b80a8e0 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -214,6 +214,13 @@ fiExpr to_drop (_, AnnNote InlineMe expr) = -- 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} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2f881d5..b3e6bf7 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -911,6 +911,14 @@ simplNote env InlineMe e cont 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} diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs index cd118d7..eb3229f 100644 --- a/compiler/simplStg/SRT.lhs +++ b/compiler/simplStg/SRT.lhs @@ -116,6 +116,8 @@ srtExpr table e@(StgOpApp op args ty) = e 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 diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs index a918739..7b341fa 100644 --- a/compiler/simplStg/StgStats.lhs +++ b/compiler/simplStg/StgStats.lhs @@ -151,6 +151,7 @@ statExpr (StgLit _) = countOne Literals 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` diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 31837b9..bdb3a66 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -318,6 +318,15 @@ coreToStgExpr (Note (SCC cc) expr) = 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 @@ -1075,6 +1084,8 @@ myCollectBinders 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) @@ -1088,6 +1099,8 @@ myCollectArgs expr 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) diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 74832a2..a184d5e 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -67,6 +67,7 @@ import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) import Bitmap import StaticFlags ( opt_SccProfilingOn ) +import Module ( Module, pprModule ) \end{code} %************************************************************************ @@ -349,6 +350,21 @@ Finally for @scc@ expressions we introduce a new STG construct. | 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} @@ -719,6 +735,10 @@ pprStgExpr (StgSCC cc expr) = 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, diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 0ec1c66..5d80433 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -526,7 +526,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, ; 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, @@ -550,7 +550,8 @@ 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)]) } @@ -655,7 +656,8 @@ tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) = 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) $ diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 139f134..bd4eb9b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -303,7 +303,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_foreign = NoStubs, + mg_hpc_info = noHpcInfo } } ; tcCoreDump mod_guts ; diff --git a/driver/mangler/ghc-asm.lprl b/driver/mangler/ghc-asm.lprl index 902593e..21b56f8 100644 --- a/driver/mangler/ghc-asm.lprl +++ b/driver/mangler/ghc-asm.lprl @@ -699,6 +699,12 @@ sub mangle_asm { $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'; diff --git a/includes/HsFFI.h b/includes/HsFFI.h index cd9f7ed..0d343f8 100644 --- a/includes/HsFFI.h +++ b/includes/HsFFI.h @@ -158,6 +158,8 @@ extern void hs_perform_gc (void); 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 diff --git a/rts/Hpc.c b/rts/Hpc.c new file mode 100644 index 0000000..8e67ffc --- /dev/null +++ b/rts/Hpc.c @@ -0,0 +1,324 @@ +/* + * (c)2006 Galois Connections, Inc. + */ + +// #include "HsFFI.h" + +#include +#include +#include +#include +#include +#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); + +} + diff --git a/rts/Hpc.h b/rts/Hpc.h new file mode 100644 index 0000000..a0ff40b --- /dev/null +++ b/rts/Hpc.h @@ -0,0 +1,10 @@ +#ifndef HPC_H +#define HPC_H + +extern void startupHpc(void); +extern void exitHpc(void); + +#endif /* HPC_H */ + + + diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index f023a96..67430dc 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -311,6 +311,8 @@ hs_add_root(void (*init_root)(void)) 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. @@ -391,6 +393,9 @@ hs_exit(void) /* 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(); -- 1.7.10.4