Commit 3b893f38 authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

Generalized Coverage pass to allow adding multiple types of Tickishs

This allows having, say, HPC ticks, automatic cost centres and source
notes active at the same time. We especially take care to un-tangle the
infrastructure involved in generating them.

(From Phabricator D169)
parent 993975d3
This diff is collapsed.
......@@ -103,16 +103,9 @@ deSugar hsc_env
; let export_set = availsToNameSet exports
target = hscTarget dflags
hpcInfo = emptyHpcInfo other_hpc_info
want_ticks = gopt Opt_Hpc dflags
|| gopt Opt_Debug dflags
|| target == HscInterpreted
|| (gopt Opt_SccProfilingOn dflags
&& case profAuto dflags of
NoProfAuto -> False
_ -> True)
; (binds_cvr, ds_hpc_info, modBreaks)
<- if want_ticks && not (isHsBootOrSig hsc_src)
<- if not (isHsBootOrSig hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
......
......@@ -599,7 +599,7 @@ cases like
(p,q) = e
-}
mkSelectorBinds :: [Maybe (Tickish Id)] -- ticks to add, possibly
mkSelectorBinds :: [[Tickish Id]] -- ticks to add, possibly
-> LPat Id -- The pattern
-> CoreExpr -- Expression to which the pattern is bound
-> DsM [(Id,CoreExpr)]
......@@ -650,7 +650,7 @@ mkSelectorBinds ticks pat val_expr
; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
where
binders = collectPatBinders pat
ticks' = ticks ++ repeat Nothing
ticks' = ticks ++ repeat []
local_binders = map localiseId binders -- See Note [Localise pattern binders]
local_tuple = mkBigCoreVarTup binders
......@@ -807,9 +807,8 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see Trac #3403.
-}
mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr
mkOptTickBox Nothing e = e
mkOptTickBox (Just tickish) e = Tick tickish e
mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox = flip (foldr Tick)
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
......
......@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ticks = (Nothing,[]) } }
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
| null cls
......
......@@ -154,7 +154,7 @@ data HsBindLR idL idR
-- See Note [Bind free vars]
fun_tick :: Maybe (Tickish Id) -- ^ Tick to put on the rhs, if any
fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
}
-- | The pattern is never a simple variable;
......@@ -168,8 +168,8 @@ data HsBindLR idL idR
pat_rhs :: GRHSs idR (LHsExpr idR),
pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)])
-- ^ Tick to put on the rhs, if any, and ticks to put on
pat_ticks :: ([Tickish Id], [[Tickish Id]])
-- ^ Ticks to put on the rhs, if any, and ticks to put on
-- the bound variables.
}
......@@ -465,10 +465,9 @@ ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
fun_co_fn = wrap,
fun_matches = matches,
fun_tick = tick })
= pprTicks empty (case tick of
Nothing -> empty
Just t -> text "-- tick id = " <> ppr t)
fun_tick = ticks })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) inf matches
$$ ifPprDebug (ppr wrap)
......
......@@ -525,7 +525,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }
, fun_tick = [] }
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
-> HsBind Name
......@@ -535,7 +535,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed
-- binding
, fun_tick = Nothing }
, fun_tick = [] }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
......
......@@ -1768,7 +1768,7 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
PatBind pat (snd $ unLoc $3)
placeHolderType
placeHolderNames
(Nothing,[]) } }
([],[]) } }
-- Turn it all into an expression so that
-- checkPattern can check that bangs are enabled
......
......@@ -927,8 +927,11 @@ makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)]
-> HsBind RdrName
-- 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 FromSource ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
= FunBind { fun_id = fn, fun_infix = is_infix,
fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper,
bind_fvs = placeHolderNames,
fun_tick = [] }
checkPatBind :: SDoc
-> LHsExpr RdrName
......@@ -937,7 +940,7 @@ checkPatBind :: SDoc
checkPatBind msg lhs (L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames
(Nothing,[])) }
([],[])) }
checkValSig
:: LHsExpr RdrName
......
......@@ -1146,9 +1146,10 @@ tcMonoBinds is_rec sig_fn no_gen
-- type of the thing whose rhs we are type checking
tcMatchesFun name inf matches 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_tick = Nothing }),
; 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_tick = [] },
[(name, Nothing, mono_id)]) }
tcMonoBinds _ sig_fn no_gen binds
......@@ -1244,7 +1245,7 @@ tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
, fun_matches = matches'
, fun_co_fn = co_fn
, bind_fvs = placeHolderNamesTc
, fun_tick = Nothing }) }
, fun_tick = [] }) }
where
tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig]
++ sig_nwcs sig) mb_sig
......@@ -1257,7 +1258,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
tcGRHSsPat grhss pat_ty
; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
, bind_fvs = placeHolderNamesTc
, pat_ticks = (Nothing,[]) }) }
, pat_ticks = ([],[]) }) }
---------------------
......
......@@ -297,7 +297,7 @@ tcPatSynMatcher (L loc name) lpat
, fun_matches = mg
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet
, fun_tick = Nothing }
, fun_tick = [] }
matcher_bind = unitBag (noLoc bind)
; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
......@@ -364,7 +364,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
, fun_matches = mg'
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNamesTc
, fun_tick = Nothing }
, fun_tick = [] }
sig = TcSigInfo{ sig_id = worker_id
, sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment