Commit d5934bbb authored by andy@galois.com's avatar andy@galois.com

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. 
				      
parent 33b8b60e
......@@ -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
......
......@@ -26,6 +26,7 @@ import CgTailCall
import CgInfoTbls
import CgForeignCall
import CgPrimOp
import CgHpc
import CgUtils
import ClosureInfo
import Cmm
......@@ -251,6 +252,16 @@ centre.
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 *
......
-----------------------------------------------------------------------------
--
-- 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"
......@@ -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
......
......@@ -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) ->
......
......@@ -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` ()
......
......@@ -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
......
......@@ -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)],
......
This diff is collapsed.
......@@ -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)
}}}
......
......@@ -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 })
......
......@@ -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}
......
......@@ -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
......@@ -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,
......
......@@ -201,6 +201,18 @@ data HsExpr id
(LHsCmdTop id) -- body of the abstraction
-- 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
......@@ -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)
......
......@@ -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
......
......@@ -1002,6 +1002,15 @@ instance Binary IfaceNote where