Module hierarchy: HsToCore (cf #13009)

1 files changed, 0 insertions, 1368 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
deleted file mode 100644
index 3e124b5829..0000000000
--- a/compiler/deSugar/Coverage.hs
+++ /dev/null
@@ -1,1368 +0,0 @@
-{-
-(c) Galois, 2006
-(c) University of Glasgow, 2007
--}
-
-{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveFunctor #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module Coverage (addTicksToBinds, hpcInitCode) where
-
-import GhcPrelude as Prelude
-
-import qualified GHC.Runtime.Interpreter as GHCi
-import GHCi.RemoteTypes
-import Data.Array
-import GHC.ByteCode.Types
-import GHC.Stack.CCS
-import Type
-import GHC.Hs
-import Module
-import Outputable
-import DynFlags
-import ConLike
-import Control.Monad
-import SrcLoc
-import ErrUtils
-import NameSet hiding (FreeVars)
-import Name
-import Bag
-import CostCentre
-import CostCentreState
-import CoreSyn
-import Id
-import VarSet
-import Data.List
-import FastString
-import HscTypes
-import TyCon
-import BasicTypes
-import MonadUtils
-import Maybes
-import GHC.Cmm.CLabel
-import Util
-
-import Data.Time
-import System.Directory
-
-import Trace.Hpc.Mix
-import Trace.Hpc.Util
-
-import qualified Data.ByteString as BS
-import Data.Map (Map)
-import qualified Data.Map as Map
-
-{-
-************************************************************************
-*                                                                      *
-*              The main function: addTicksToBinds
-*                                                                      *
-************************************************************************
--}
-
-addTicksToBinds
-        :: HscEnv
-        -> Module
-        -> ModLocation          -- ... off the current module
-        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
-                                -- isExportedId doesn't work yet (the desugarer
-                                -- hasn't set it), so we have to work from this set.
-        -> [TyCon]              -- Type constructor in this module
-        -> LHsBinds GhcTc
-        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
-
-addTicksToBinds hsc_env mod mod_loc exports tyCons binds
-  | let dflags = hsc_dflags hsc_env
-        passes = coveragePasses dflags, not (null passes),
-    Just orig_file <- ml_hs_file mod_loc,
-    not ("boot" `isSuffixOf` orig_file) = do
-
-     let  orig_file2 = guessSourceFile binds orig_file
-
-          tickPass tickish (binds,st) =
-            let env = TTE
-                      { fileName     = mkFastString orig_file2
-                      , declPath     = []
-                      , tte_dflags   = dflags
-                      , exports      = exports
-                      , inlines      = emptyVarSet
-                      , inScope      = emptyVarSet
-                      , blackList    = Map.fromList
-                                          [ (getSrcSpan (tyConName tyCon),())
-                                          | tyCon <- tyCons ]
-                      , density      = mkDensity tickish dflags
-                      , this_mod     = mod
-                      , tickishType  = tickish
-                      }
-                (binds',_,st') = unTM (addTickLHsBinds binds) env st
-            in (binds', st')
-
-          initState = TT { tickBoxCount = 0
-                         , mixEntries   = []
-                         , ccIndices    = newCostCentreState
-                         }
-
-          (binds1,st) = foldr tickPass (binds, initState) passes
-
-     let tickCount = tickBoxCount st
-         entries = reverse $ mixEntries st
-     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
-     modBreaks <- mkModBreaks hsc_env mod tickCount entries
-
-     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
-       (pprLHsBinds binds1)
-
-     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
-
-  | otherwise = return (binds, emptyHpcInfo False, Nothing)
-
-guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
-guessSourceFile binds orig_file =
-     -- Try look for a file generated from a .hsc file to a
-     -- .hs file, by peeking ahead.
-     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
-                                 srcSpanFileName_maybe pos : rest) [] binds
-     in
-     case top_pos of
-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
-                      -> unpackFS file_name
-        _ -> orig_file
-
-
-mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
-mkModBreaks hsc_env mod count entries
-  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
-    breakArray <- GHCi.newBreakArray hsc_env (length entries)
-    ccs <- mkCCSArray hsc_env mod count entries
-    let
-           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
-           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
-           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
-    return emptyModBreaks
-                       { modBreaks_flags = breakArray
-                       , modBreaks_locs  = locsTicks
-                       , modBreaks_vars  = varsTicks
-                       , modBreaks_decls = declsTicks
-                       , modBreaks_ccs   = ccs
-                       }
-  | otherwise = return emptyModBreaks
-
-mkCCSArray
-  :: HscEnv -> Module -> Int -> [MixEntry_]
-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
-mkCCSArray hsc_env modul count entries = do
-  if interpreterProfiled dflags
-    then do
-      let module_str = moduleNameString (moduleName modul)
-      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
-      return (listArray (0,count-1) costcentres)
-    else do
-      return (listArray (0,-1) [])
- where
-    dflags = hsc_dflags hsc_env
-    mk_one (srcspan, decl_path, _, _) = (name, src)
-      where name = concat (intersperse "." decl_path)
-            src = showSDoc dflags (ppr srcspan)
-
-
-writeMixEntries
-  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
-writeMixEntries dflags mod count entries filename
-  | not (gopt Opt_Hpc dflags) = return 0
-  | otherwise   = do
-        let
-            hpc_dir = hpcDir dflags
-            mod_name = moduleNameString (moduleName mod)
-
-            hpc_mod_dir
-              | moduleUnitId mod == mainUnitId  = hpc_dir
-              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
-
-            tabStop = 8 -- <tab> counts as a normal char in GHC's
-                        -- location ranges.
-
-        createDirectoryIfMissing True hpc_mod_dir
-        modTime <- getModificationUTCTime filename
-        let entries' = [ (hpcPos, box)
-                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
-        when (entries' `lengthIsNot` count) $ do
-          panic "the number of .mix entries are inconsistent"
-        let hashNo = mixHash filename modTime tabStop entries'
-        mixCreate hpc_mod_dir mod_name
-                       $ Mix filename modTime (toHash hashNo) tabStop entries'
-        return hashNo
-
-
--- -----------------------------------------------------------------------------
--- TickDensity: where to insert ticks
-
-data TickDensity
-  = TickForCoverage       -- for Hpc
-  | TickForBreakPoints    -- for GHCi
-  | TickAllFunctions      -- for -prof-auto-all
-  | TickTopFunctions      -- for -prof-auto-top
-  | TickExportedFunctions -- for -prof-auto-exported
-  | TickCallSites         -- for stack tracing
-  deriving Eq
-
-mkDensity :: TickishType -> DynFlags -> TickDensity
-mkDensity tickish dflags = case tickish of
-  HpcTicks             -> TickForCoverage
-  SourceNotes          -> TickForCoverage
-  Breakpoints          -> TickForBreakPoints
-  ProfNotes ->
-    case profAuto dflags of
-      ProfAutoAll      -> TickAllFunctions
-      ProfAutoTop      -> TickTopFunctions
-      ProfAutoExports  -> TickExportedFunctions
-      ProfAutoCalls    -> TickCallSites
-      _other           -> panic "mkDensity"
-
--- | Decide whether to add a tick to a binding or not.
-shouldTickBind  :: TickDensity
-                -> Bool         -- top level?
-                -> Bool         -- exported?
-                -> Bool         -- simple pat bind?
-                -> Bool         -- INLINE pragma?
-                -> Bool
-
-shouldTickBind density top_lev exported _simple_pat inline
- = case density of
-      TickForBreakPoints    -> False
-        -- we never add breakpoints to simple pattern bindings
-        -- (there's always a tick on the rhs anyway).
-      TickAllFunctions      -> not inline
-      TickTopFunctions      -> top_lev && not inline
-      TickExportedFunctions -> exported && not inline
-      TickForCoverage       -> True
-      TickCallSites         -> False
-
-shouldTickPatBind :: TickDensity -> Bool -> Bool
-shouldTickPatBind density top_lev
-  = case density of
-      TickForBreakPoints    -> False
-      TickAllFunctions      -> True
-      TickTopFunctions      -> top_lev
-      TickExportedFunctions -> False
-      TickForCoverage       -> False
-      TickCallSites         -> False
-
--- -----------------------------------------------------------------------------
--- Adding ticks to bindings
-
-addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
-addTickLHsBinds = mapBagM addTickLHsBind
-
-addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
-                                       abs_exports = abs_exports })) = do
-  withEnv add_exports $ do
-  withEnv add_inlines $ do
-  binds' <- addTickLHsBinds binds
-  return $ L pos $ bind { abs_binds = binds' }
- where
-   -- in AbsBinds, the Id on each binding is not the actual top-level
-   -- Id that we are defining, they are related by the abs_exports
-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
-   -- to add the local Ids to the set of exported Names so that we know to
-   -- tick the right bindings.
-   add_exports env =
-     env{ exports = exports env `extendNameSetList`
-                      [ idName mid
-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
-                      , idName pid `elemNameSet` (exports env) ] }
-
-   -- See Note [inline sccs]
-   add_inlines env =
-     env{ inlines = inlines env `extendVarSetList`
-                      [ mid
-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
-                      , isInlinePragma (idInlinePragma pid) ] }
-
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
-  let name = getOccString id
-  decl_path <- getPathEntry
-  density <- getDensity
-
-  inline_ids <- liftM inlines getEnv
-  -- See Note [inline sccs]
-  let inline   = isInlinePragma (idInlinePragma id)
-                 || id `elemVarSet` inline_ids
-
-  -- See Note [inline sccs]
-  tickish <- tickishType `liftM` getEnv
-  if inline && tickish == ProfNotes then return (L pos funBind) else do
-
-  (fvs, mg) <-
-        getFreeVars $
-        addPathEntry name $
-        addTickMatchGroup False (fun_matches funBind)
-
-  case mg of
-    MG {} -> return ()
-    _     -> panic "addTickLHsBind"
-
-  blackListed <- isBlackListed pos
-  exported_names <- liftM exports getEnv
-
-  -- We don't want to generate code for blacklisted positions
-  -- We don't want redundant ticks on simple pattern bindings
-  -- We don't want to tick non-exported bindings in TickExportedFunctions
-  let simple = isSimplePatBind funBind
-      toplev = null decl_path
-      exported = idName id `elemNameSet` exported_names
-
-  tick <- if not blackListed &&
-               shouldTickBind density toplev exported simple inline
-             then
-                bindTick density name pos fvs
-             else
-                return Nothing
-
-  let mbCons = maybe Prelude.id (:)
-  return $ L pos $ funBind { fun_matches = mg
-                           , fun_tick = tick `mbCons` fun_tick funBind }
-
-   where
-   -- a binding is a simple pattern binding if it is a funbind with
-   -- zero patterns
-   isSimplePatBind :: HsBind GhcTc -> Bool
-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-
--- TODO: Revisit this
-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
-                                    , pat_rhs = rhs }))) = do
-
-  let simplePatId = isSimplePat lhs
-
-  -- TODO: better name for rhs's for non-simple patterns?
-  let name = maybe "(...)" getOccString simplePatId
-
-  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
-  let pat' = pat { pat_rhs = rhs'}
-
-  -- Should create ticks here?
-  density <- getDensity
-  decl_path <- getPathEntry
-  let top_lev = null decl_path
-  if not (shouldTickPatBind density top_lev)
-    then return (L pos pat')
-    else do
-
-    let mbCons = maybe id (:)
-
-    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
-
-    -- Allocate the ticks
-
-    rhs_tick <- bindTick density name pos fvs
-    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
-
-    patvar_tickss <- case simplePatId of
-      Just{} -> return initial_patvar_tickss
-      Nothing -> do
-        let patvars = map getOccString (collectPatBinders lhs)
-        patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
-        return
-          (zipWith mbCons patvar_ticks
-                          (initial_patvar_tickss ++ repeat []))
-
-    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-
--- Only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
-addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
-
-bindTick
-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
-bindTick density name pos fvs = do
-  decl_path <- getPathEntry
-  let
-      toplev        = null decl_path
-      count_entries = toplev || density == TickAllFunctions
-      top_only      = density /= TickAllFunctions
-      box_label     = if toplev then TopLevelBox [name]
-                                else LocalBox (decl_path ++ [name])
-  --
-  allocATickBox box_label count_entries top_only pos fvs
-
-
--- Note [inline sccs]
---
--- The reason not to add ticks to INLINE functions is that this is
--- sometimes handy for avoiding adding a tick to a particular function
--- (see #6131)
---
--- So for now we do not add any ticks to INLINE functions at all.
---
--- We used to use isAnyInlinePragma to figure out whether to avoid adding
--- ticks for this purpose. However, #12962 indicates that this contradicts
--- the documentation on profiling (which only mentions INLINE pragmas).
--- So now we're more careful about what we avoid adding ticks to.
-
--- -----------------------------------------------------------------------------
--- Decorate an LHsExpr with ticks
-
--- selectively add ticks to interesting expressions
-addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(L pos e0) = do
-  d <- getDensity
-  case d of
-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
-    TickForCoverage    -> tick_it
-    TickCallSites      | isCallSite e0      -> tick_it
-    _other             -> dont_tick_it
- where
-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- Add a tick to an expression which is the RHS of an equation or a binding.
--- We always consider these to be breakpoints, unless the expression is a 'let'
--- (because the body will definitely have a tick somewhere).  ToDo: perhaps
--- we should treat 'case' and 'if' the same way?
-addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprRHS e@(L pos e0) = do
-  d <- getDensity
-  case d of
-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-                        | otherwise     -> tick_it
-     TickForCoverage -> tick_it
-     TickCallSites   | isCallSite e0 -> tick_it
-     _other          -> dont_tick_it
- where
-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- The inner expression of an evaluation context:
---    let binds in [], ( [] )
--- we never tick these if we're doing HPC, but otherwise
--- we treat it like an ordinary expression.
-addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprEvalInner e = do
-   d <- getDensity
-   case d of
-     TickForCoverage -> addTickLHsExprNever e
-     _otherwise      -> addTickLHsExpr e
-
--- | A let body is treated differently from addTickLHsExprEvalInner
--- above with TickForBreakPoints, because for breakpoints we always
--- want to tick the body, even if it is not a redex.  See test
--- break012.  This gives the user the opportunity to inspect the
--- values of the let-bound variables.
-addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprLetBody e@(L pos e0) = do
-  d <- getDensity
-  case d of
-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-                        | otherwise     -> tick_it
-     _other -> addTickLHsExprEvalInner e
- where
-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- version of addTick that does not actually add a tick,
--- because the scope of this tick is completely subsumed by
--- another.
-addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (L pos e0) = do
-    e1 <- addTickHsExpr e0
-    return $ L pos e1
-
--- general heuristic: expressions which do not denote values are good
--- break points
-isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {})     = True
-isGoodBreakExpr (HsAppType {}) = True
-isGoodBreakExpr (OpApp {})     = True
-isGoodBreakExpr _other         = False
-
-isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{}     = True
-isCallSite HsAppType{} = True
-isCallSite OpApp{}     = True
-isCallSite _ = False
-
-addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (L pos e0)
-  = ifDensity TickForCoverage
-        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
-
-addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (L pos e0)
-  = ifDensity TickForCoverage
-        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
-
-
--- -----------------------------------------------------------------------------
--- Decorate the body of an HsExpr with ticks.
--- (Whether to put a tick around the whole expression was already decided,
--- in the addTickLHsExpr family of functions.)
-
-addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut _ con)
-  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar {})       = return e
-addTickHsExpr e@(HsOverLit {})     = return e
-addTickHsExpr e@(HsOverLabel{})    = return e
-addTickHsExpr e@(HsLit {})         = return e
-addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
-                                           (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
-                                           (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
-                                                      (addTickLHsExpr      e2)
-addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
-                                                      (addTickLHsExprNever e)
-                                                      (return ty)
-
-addTickHsExpr (OpApp fix e1 e2 e3) =
-        liftM4 OpApp
-                (return fix)
-                (addTickLHsExpr e1)
-                (addTickLHsExprNever e2)
-                (addTickLHsExpr e3)
-addTickHsExpr (NegApp x e neg) =
-        liftM2 (NegApp x)
-                (addTickLHsExpr e)
-                (addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar x e) =
-        liftM (HsPar x) (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL x e1 e2) =
-        liftM2 (SectionL x)
-                (addTickLHsExpr e1)
-                (addTickLHsExprNever e2)
-addTickHsExpr (SectionR x e1 e2) =
-        liftM2 (SectionR x)
-                (addTickLHsExprNever e1)
-                (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple x es boxity) =
-        liftM2 (ExplicitTuple x)
-                (mapM addTickTupArg es)
-                (return boxity)
-addTickHsExpr (ExplicitSum ty tag arity e) = do
-        e' <- addTickLHsExpr e
-        return (ExplicitSum ty tag arity e')
-addTickHsExpr (HsCase x e mgs) =
-        liftM2 (HsCase x)
-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-                                   -- be evaluated.
-                (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf x cnd e1 e2 e3) =
-        liftM3 (HsIf x cnd)
-                (addBinTickLHsExpr (BinBox CondBinBox) e1)
-                (addTickLHsExprOptAlt True e2)
-                (addTickLHsExprOptAlt True e3)
-addTickHsExpr (HsMultiIf ty alts)
-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
-       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
-       ; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x (L l binds) e) =
-        bindLocals (collectLocalBinders binds) $
-          liftM2 (HsLet x . L l)
-                  (addTickHsLocalBinds binds) -- to think about: !patterns.
-                  (addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
-       ; return (HsDo srcloc cxt (L l stmts')) }
-  where
-        forQual = case cxt of
-                    ListComp -> Just $ BinBox QualBinBox
-                    _        -> Nothing
-addTickHsExpr (ExplicitList ty wit es) =
-        liftM3 ExplicitList
-                (return ty)
-                (addTickWit wit)
-                (mapM (addTickLHsExpr) es)
-             where addTickWit Nothing = return Nothing
-                   addTickWit (Just fln)
-                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
-                          return (Just fln')
-
-addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
-
-addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
-  = do { rec_binds' <- addTickHsRecordBinds rec_binds
-       ; return (expr { rcon_flds = rec_binds' }) }
-
-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
-  = do { e' <- addTickLHsExpr e
-       ; flds' <- mapM addTickHsRecField flds
-       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-
-addTickHsExpr (ExprWithTySig x e ty) =
-        liftM3 ExprWithTySig
-                (return x)
-                (addTickLHsExprNever e) -- No need to tick the inner expression
-                                        -- for expressions with signatures
-                (return ty)
-addTickHsExpr (ArithSeq ty wit arith_seq) =
-        liftM3 ArithSeq
-                (return ty)
-                (addTickWit wit)
-                (addTickArithSeqInfo arith_seq)
-             where addTickWit Nothing = return Nothing
-                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
-                                             return (Just fl')
-
--- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick x t e) =
-        liftM (HsTick x t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick x t0 t1 e) =
-        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-
-addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
-    e2 <- allocTickBox (ExpBox False) False False pos $
-                addTickHsExpr e0
-    return $ unLoc e2
-addTickHsExpr (HsPragE x p e) =
-        liftM (HsPragE x p) (addTickLHsExpr e)
-addTickHsExpr e@(HsBracket     {})   = return e
-addTickHsExpr e@(HsTcBracketOut  {}) = return e
-addTickHsExpr e@(HsRnBracketOut  {}) = return e
-addTickHsExpr e@(HsSpliceE  {})      = return e
-addTickHsExpr (HsProc x pat cmdtop) =
-        liftM2 (HsProc x)
-                (addTickLPat pat)
-                (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (HsWrap w e)) =
-        liftM XExpr $
-        liftM (HsWrap w)
-              (addTickHsExpr e)        -- Explicitly no tick on inside
-
--- Others should never happen in expression content.
-addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
-
-addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present x e))  = do { e' <- addTickLHsExpr e
-                                        ; return (L l (Present x e')) }
-addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
-addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
-
-
-addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
-  let isOneOfMany = matchesOneOfMany matches
-  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
-  return $ mg { mg_alts = L l matches' }
-addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
-
-addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-             -> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
-                                               , m_grhss = gRHSs }) =
-  bindLocals (collectPatsBinders pats) $ do
-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ match { m_grhss = gRHSs' }
-addTickMatch _ _ (XMatch nec) = noExtCon nec
-
-addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
-  bindLocals binders $ do
-    local_binds' <- addTickHsLocalBinds local_binds
-    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
-    return $ GRHSs x guarded' (L l local_binds')
-  where
-    binders = collectLocalBinders local_binds
-addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
-
-addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-            -> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
-                        (addTickGRHSBody isOneOfMany isLambda expr)
-  return $ GRHS x stmts' expr'
-addTickGRHS _ _ (XGRHS nec) = noExtCon nec
-
-addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
-  d <- getDensity
-  case d of
-    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
-    TickAllFunctions | isLambda ->
-       addPathEntry "\\" $
-         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
-           addTickHsExpr e0
-    _otherwise ->
-       addTickLHsExprRHS expr
-
-addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
-              -> TM [ExprLStmt GhcTc]
-addTickLStmts isGuard stmts = do
-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
-  return stmts
-
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
-               -> TM ([ExprLStmt GhcTc], a)
-addTickLStmts' isGuard lstmts res
-  = bindLocals (collectLStmtsBinders lstmts) $
-    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
-       ; a <- res
-       ; return (lstmts', a) }
-
-addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
-            -> TM (Stmt GhcTc (LHsExpr GhcTc))
-addTickStmt _isGuard (LastStmt x e noret ret) = do
-        liftM3 (LastStmt x)
-                (addTickLHsExpr e)
-                (pure noret)
-                (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt x pat e bind fail) = do
-        liftM4 (BindStmt x)
-                (addTickLPat pat)
-                (addTickLHsExprRHS e)
-                (addTickSyntaxExpr hpcSrcSpan bind)
-                (addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (BodyStmt x e bind' guard') = do
-        liftM3 (BodyStmt x)
-                (addTick isGuard e)
-                (addTickSyntaxExpr hpcSrcSpan bind')
-                (addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x (L l binds)) = do
-        liftM (LetStmt x . L l)
-                (addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
-    liftM3 (ParStmt x)
-        (mapM (addTickStmtAndBinders isGuard) pairs)
-        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
-        (addTickSyntaxExpr hpcSrcSpan bindExpr)
-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
-    args' <- mapM (addTickApplicativeArg isGuard) args
-    return (ApplicativeStmt body_ty args' mb_join)
-
-addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
-                                    , trS_by = by, trS_using = using
-                                    , trS_ret = returnExpr, trS_bind = bindExpr
-                                    , trS_fmap = liftMExpr }) = do
-    t_s <- addTickLStmts isGuard stmts
-    t_y <- fmapMaybeM  addTickLHsExprRHS by
-    t_u <- addTickLHsExprRHS using
-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
-    t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))
-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
-
-addTickStmt isGuard stmt@(RecStmt {})
-  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-
-addTickStmt _ (XStmtLR nec) = noExtCon nec
-
-addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
-                  | otherwise          = addTickLHsExprRHS e
-
-addTickApplicativeArg
-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
-  addTickArg (ApplicativeArgOne x pat expr isBody fail) =
-    (ApplicativeArgOne x)
-      <$> addTickLPat pat
-      <*> addTickLHsExpr expr
-      <*> pure isBody
-      <*> addTickSyntaxExpr hpcSrcSpan fail
-  addTickArg (ApplicativeArgMany x stmts ret pat) =
-    (ApplicativeArgMany x)
-      <$> addTickLStmts isGuard stmts
-      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
-      <*> addTickLPat pat
-  addTickArg (XApplicativeArg nec) = noExtCon nec
-
-addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-                      -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
-    liftM3 (ParStmtBlock x)
-        (addTickLStmts isGuard stmts)
-        (return ids)
-        (addTickSyntaxExpr hpcSrcSpan returnExpr)
-addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
-
-addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
-addTickHsLocalBinds (HsValBinds x binds) =
-        liftM (HsValBinds x)
-                (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds x binds)  =
-        liftM (HsIPBinds x)
-                (addTickHsIPBinds binds)
-addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
-addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
-
-addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-                  -> TM (HsValBindsLR GhcTc (GhcPass b))
-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
-        b <- liftM2 NValBinds
-                (mapM (\ (rec,binds') ->
-                                liftM2 (,)
-                                        (return rec)
-                                        (addTickLHsBinds binds'))
-                        binds)
-                (return sigs)
-        return $ XValBindsLR b
-addTickHsValBinds _ = panic "addTickHsValBinds"
-
-addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
-addTickHsIPBinds (IPBinds dictbinds ipbinds) =
-        liftM2 IPBinds
-                (return dictbinds)
-                (mapM (liftL (addTickIPBind)) ipbinds)
-addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
-
-addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
-addTickIPBind (IPBind x nm e) =
-        liftM2 (IPBind x)
-                (return nm)
-                (addTickLHsExpr e)
-addTickIPBind (XIPBind x) = return (XIPBind x)
-
--- There is no location here, so we might need to use a context location??
-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
-addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
-        x' <- fmap unLoc (addTickLHsExpr (L pos x))
-        return $ syn { syn_expr = x' }
-addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
-
--- we do not walk into patterns.
-addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
-addTickLPat pat = return pat
-
-addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop x cmd) =
-        liftM2 HsCmdTop
-                (return x)
-                (addTickLHsCmd cmd)
-addTickHsCmdTop (XCmdTop nec) = noExtCon nec
-
-addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (L pos c0) = do
-        c1 <- addTickHsCmd c0
-        return $ L pos c1
-
-addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam x matchgroup) =
-        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp x c e) =
-        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
-{-
-addTickHsCmd (OpApp e1 c2 fix c3) =
-        liftM4 OpApp
-                (addTickLHsExpr e1)
-                (addTickLHsCmd c2)
-                (return fix)
-                (addTickLHsCmd c3)
--}
-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase x e mgs) =
-        liftM2 (HsCmdCase x)
-                (addTickLHsExpr e)
-                (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
-        liftM3 (HsCmdIf x cnd)
-                (addBinTickLHsExpr (BinBox CondBinBox) e1)
-                (addTickLHsCmd c2)
-                (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (L l binds) c) =
-        bindLocals (collectLocalBinders binds) $
-          liftM2 (HsCmdLet x . L l)
-                   (addTickHsLocalBinds binds) -- to think about: !patterns.
-                   (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (L l stmts))
-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo srcloc (L l stmts')) }
-
-addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
-        liftM5 HsCmdArrApp
-               (return arr_ty)
-               (addTickLHsExpr e1)
-               (addTickLHsExpr e2)
-               (return ty1)
-               (return lr)
-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
-        liftM4 (HsCmdArrForm x)
-               (addTickLHsExpr e)
-               (return f)
-               (return fix)
-               (mapM (liftL (addTickHsCmdTop)) cmdtop)
-
-addTickHsCmd (XCmd (HsWrap w cmd)) =
-  liftM XCmd $
-  liftM (HsWrap w) (addTickHsCmd cmd)
-
--- Others should never happen in a command context.
---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
-
-addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
-  matches' <- mapM (liftL addTickCmdMatch) matches
-  return $ mg { mg_alts = L l matches' }
-addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
-
-addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
-  bindLocals (collectPatsBinders pats) $ do
-    gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ match { m_grhss = gRHSs' }
-addTickCmdMatch (XMatch nec) = noExtCon nec
-
-addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
-  bindLocals binders $ do
-    local_binds' <- addTickHsLocalBinds local_binds
-    guarded' <- mapM (liftL addTickCmdGRHS) guarded
-    return $ GRHSs x guarded' (L l local_binds')
-  where
-    binders = collectLocalBinders local_binds
-addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
-
-addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
--- The *guards* are *not* Cmds, although the body is
--- C.f. addTickGRHS for the BinBox stuff
-addTickCmdGRHS (GRHS x stmts cmd)
-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
-                                   stmts (addTickLHsCmd cmd)
-       ; return $ GRHS x stmts' expr' }
-addTickCmdGRHS (XGRHS nec) = noExtCon nec
-
-addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
-                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
-addTickLCmdStmts stmts = do
-  (stmts, _) <- addTickLCmdStmts' stmts (return ())
-  return stmts
-
-addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
-                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
-addTickLCmdStmts' lstmts res
-  = bindLocals binders $ do
-        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
-        a <- res
-        return (lstmts', a)
-  where
-        binders = collectLStmtsBinders lstmts
-
-addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt x pat c bind fail) = do
-        liftM4 (BindStmt x)
-                (addTickLPat pat)
-                (addTickLHsCmd c)
-                (return bind)
-                (return fail)
-addTickCmdStmt (LastStmt x c noret ret) = do
-        liftM3 (LastStmt x)
-                (addTickLHsCmd c)
-                (pure noret)
-                (addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (BodyStmt x c bind' guard') = do
-        liftM3 (BodyStmt x)
-                (addTickLHsCmd c)
-                (addTickSyntaxExpr hpcSrcSpan bind')
-                (addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x (L l binds)) = do
-        liftM (LetStmt x . L l)
-                (addTickHsLocalBinds binds)
-addTickCmdStmt stmt@(RecStmt {})
-  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt ApplicativeStmt{} =
-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-addTickCmdStmt (XStmtLR nec) =
-  noExtCon nec
-
--- Others should never happen in a command context.
-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
-
-addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
-addTickHsRecordBinds (HsRecFields fields dd)
-  = do  { fields' <- mapM addTickHsRecField fields
-        ; return (HsRecFields fields' dd) }
-
-addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
-                  -> TM (LHsRecField' id (LHsExpr GhcTc))
-addTickHsRecField (L l (HsRecField id expr pun))
-        = do { expr' <- addTickLHsExpr expr
-             ; return (L l (HsRecField id expr' pun)) }
-
-
-addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
-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)
-
-data TickTransState = TT { tickBoxCount:: Int
-                         , mixEntries  :: [MixEntry_]
-                         , ccIndices   :: CostCentreState
-                         }
-
-data TickTransEnv = TTE { fileName     :: FastString
-                        , density      :: TickDensity
-                        , tte_dflags   :: DynFlags
-                        , exports      :: NameSet
-                        , inlines      :: VarSet
-                        , declPath     :: [String]
-                        , inScope      :: VarSet
-                        , blackList    :: Map SrcSpan ()
-                        , this_mod     :: Module
-                        , tickishType  :: TickishType
-                        }
-
---      deriving Show
-
-data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
-                 deriving (Eq)
-
-coveragePasses :: DynFlags -> [TickishType]
-coveragePasses dflags =
-    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
-    ifa (gopt Opt_Hpc dflags)                HpcTicks $
-    ifa (gopt Opt_SccProfilingOn dflags &&
-         profAuto dflags /= NoProfAuto)      ProfNotes $
-    ifa (debugLevel dflags > 0)              SourceNotes []
-  where ifa f x xs | f         = x:xs
-                   | otherwise = xs
-
--- | Tickishs that only make sense when their source code location
--- refers to the current file. This might not always be true due to
--- LINE pragmas in the code - which would confuse at least HPC.
-tickSameFileOnly :: TickishType -> Bool
-tickSameFileOnly HpcTicks = True
-tickSameFileOnly _other   = False
-
-type FreeVars = OccEnv Id
-noFVs :: FreeVars
-noFVs = emptyOccEnv
-
--- Note [freevars]
---   For breakpoints we want to collect the free variables of an
---   expression for pinning on the HsTick.  We don't want to collect
---   *all* free variables though: in particular there's no point pinning
---   on free variables that are will otherwise be in scope at the GHCi
---   prompt, which means all top-level bindings.  Unfortunately detecting
---   top-level bindings isn't easy (collectHsBindsBinders on the top-level
---   bindings doesn't do it), so we keep track of a set of "in-scope"
---   variables in addition to the free variables, and the former is used
---   to filter additions to the latter.  This gives us complete control
---   over what free variables we track.
-
-newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
-    deriving (Functor)
-        -- a combination of a state monad (TickTransState) and a writer
-        -- monad (FreeVars).
-
-instance Applicative TM where
-    pure a = TM $ \ _env st -> (a,noFVs,st)
-    (<*>) = ap
-
-instance Monad TM where
-  (TM m) >>= k = TM $ \ env st ->
-                                case m env st of
-                                  (r1,fv1,st1) ->
-                                     case unTM (k r1) env st1 of
-                                       (r2,fv2,st2) ->
-                                          (r2, fv1 `plusOccEnv` fv2, st2)
-
-instance HasDynFlags TM where
-  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
-
--- | Get the next HPC cost centre index for a given centre name
-getCCIndexM :: FastString -> TM CostCentreIndex
-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
-                                                 ccIndices st
-                              in (idx, noFVs, st { ccIndices = is' })
-
-getState :: TM TickTransState
-getState = TM $ \ _ st -> (st, noFVs, st)
-
-setState :: (TickTransState -> TickTransState) -> TM ()
-setState f = TM $ \ _ st -> ((), noFVs, f st)
-
-getEnv :: TM TickTransEnv
-getEnv = TM $ \ env st -> (env, noFVs, st)
-
-withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
-withEnv f (TM m) = TM $ \ env st ->
-                                 case m (f env) st of
-                                   (a, fvs, st') -> (a, fvs, st')
-
-getDensity :: TM TickDensity
-getDensity = TM $ \env st -> (density env, noFVs, st)
-
-ifDensity :: TickDensity -> TM a -> TM a -> TM a
-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
-
-getFreeVars :: TM a -> TM (FreeVars, a)
-getFreeVars (TM m)
-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
-
-freeVar :: Id -> TM ()
-freeVar id = TM $ \ env st ->
-                if id `elemVarSet` inScope env
-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
-                   else ((), noFVs, st)
-
-addPathEntry :: String -> TM a -> TM a
-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
-
-getPathEntry :: TM [String]
-getPathEntry = declPath `liftM` getEnv
-
-getFileName :: TM FastString
-getFileName = fileName `liftM` getEnv
-
-isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
-isGoodSrcSpan' (UnhelpfulSpan _) = False
-
-isGoodTickSrcSpan :: SrcSpan -> TM Bool
-isGoodTickSrcSpan pos = do
-  file_name <- getFileName
-  tickish <- tickishType `liftM` getEnv
-  let need_same_file = tickSameFileOnly tickish
-      same_file      = Just file_name == srcSpanFileName_maybe pos
-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
-
-ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
-ifGoodTickSrcSpan pos then_code else_code = do
-  good <- isGoodTickSrcSpan pos
-  if good then then_code else else_code
-
-bindLocals :: [Id] -> TM a -> TM a
-bindLocals new_ids (TM m)
-  = TM $ \ env st ->
-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
-  where occs = [ nameOccName (idName id) | id <- new_ids ]
-
-isBlackListed :: SrcSpan -> TM Bool
-isBlackListed pos = TM $ \ env st ->
-              case Map.lookup pos (blackList env) of
-                Nothing -> (False,noFVs,st)
-                Just () -> (True,noFVs,st)
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
-             -> TM (LHsExpr GhcTc)
-allocTickBox boxLabel countEntries topOnly pos m =
-  ifGoodTickSrcSpan pos (do
-    (fvs, e) <- getFreeVars m
-    env <- getEnv
-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
-    return (L pos (HsTick noExtField tickish (L pos e)))
-  ) (do
-    e <- m
-    return (L pos e)
-  )
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
-              -> TM (Maybe (Tickish Id))
-allocATickBox boxLabel countEntries topOnly  pos fvs =
-  ifGoodTickSrcSpan pos (do
-    let
-      mydecl_path = case boxLabel of
-                      TopLevelBox x -> x
-                      LocalBox xs  -> xs
-                      _ -> panic "allocATickBox"
-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
-    return (Just tickish)
-  ) (return Nothing)
-
-
-mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
-          -> TM (Tickish Id)
-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
-
-  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
-          -- unlifted types cause two problems here:
-          --   * we can't bind them  at the GHCi prompt
-          --     (bindLocalsAtBreakpoint already filters them out),
-          --   * the simplifier might try to substitute a literal for
-          --     the Id, and we can't handle that.
-
-      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
-
-      cc_name | topOnly   = head decl_path
-              | otherwise = concat (intersperse "." decl_path)
-
-  dflags <- getDynFlags
-  env <- getEnv
-  case tickishType env of
-    HpcTicks -> do
-      c <- liftM tickBoxCount getState
-      setState $ \st -> st { tickBoxCount = c + 1
-                           , mixEntries = me : mixEntries st }
-      return $ HpcTick (this_mod env) c
-
-    ProfNotes -> do
-      let nm = mkFastString cc_name
-      flavour <- HpcCC <$> getCCIndexM nm
-      let cc = mkUserCC nm (this_mod env) pos flavour
-          count = countEntries && gopt Opt_ProfCountEntries dflags
-      return $ ProfNote cc count True{-scopes-}
-
-    Breakpoints -> do
-      c <- liftM tickBoxCount getState
-      setState $ \st -> st { tickBoxCount = c + 1
-                           , mixEntries = me:mixEntries st }
-      return $ Breakpoint c ids
-
-    SourceNotes | RealSrcSpan pos' <- pos ->
-      return $ SourceNote pos' cc_name
-
-    _otherwise -> panic "mkTickish: bad source span!"
-
-
-allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
-                -> TM (LHsExpr GhcTc)
-allocBinTickBox boxLabel pos m = do
-  env <- getEnv
-  case tickishType env of
-    HpcTicks -> do e <- liftM (L pos) m
-                   ifGoodTickSrcSpan pos
-                     (mkBinTickBoxHpc boxLabel pos e)
-                     (return e)
-    _other   -> allocTickBox (ExpBox False) False False pos m
-
-mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
-                -> TM (LHsExpr GhcTc)
-mkBinTickBoxHpc boxLabel pos e =
- TM $ \ env st ->
-  let meT = (pos,declPath env, [],boxLabel True)
-      meF = (pos,declPath env, [],boxLabel False)
-      meE = (pos,declPath env, [],ExpBox False)
-      c = tickBoxCount st
-      mes = mixEntries st
-  in
-     ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
-          $ L pos $ HsBinTick noExtField (c+1) (c+2) e
-   -- notice that F and T are reversed,
-   -- because we are building the list in
-   -- reverse...
-     , noFVs
-     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
-     )
-
-mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos@(RealSrcSpan s)
-   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
-                                    srcSpanStartCol s,
-                                    srcSpanEndLine s,
-                                    srcSpanEndCol s - 1)
-                              -- the end column of a SrcSpan is one
-                              -- greater than the last column of the
-                              -- span (see SrcLoc), whereas HPC
-                              -- expects to the column range to be
-                              -- inclusive, hence we subtract one above.
-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
-
-hpcSrcSpan :: SrcSpan
-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
-
-matchesOneOfMany :: [LMatch GhcTc body] -> Bool
-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
-  where
-        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
-          = length grhss
-        matchCount (L _ (Match { m_grhss = XGRHSs nec }))
-          = noExtCon nec
-        matchCount (L _ (XMatch nec)) = noExtCon nec
-
-type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
-
--- For the hash value, we hash everything: the file name,
---  the timestamp of the original source file, the tab stop,
---  and the mix entries. We cheat, and hash the show'd string.
--- This hash only has to be hashed at Mix creation time,
--- and is for sanity checking only.
-
-mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
-mixHash file tm tabstop entries = fromIntegral $ hashString
-        (show $ Mix file tm 0 tabstop entries)
-
-{-
-************************************************************************
-*                                                                      *
-*              initialisation
-*                                                                      *
-************************************************************************
-
-Each module compiled with -fhpc declares an initialisation function of
-the form `hpc_init_<module>()`, which is emitted into the _stub.c file
-and annotated with __attribute__((constructor)) so that it gets
-executed at startup time.
-
-The function's purpose is to call hs_hpc_module to register this
-module with the RTS, and it looks something like this:
-
-static void hpc_init_Main(void) __attribute__((constructor));
-static void hpc_init_Main(void)
-{extern StgWord64 _hpc_tickboxes_Main_hpc[];
- hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
--}
-
-hpcInitCode :: Module -> HpcInfo -> SDoc
-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
-hpcInitCode this_mod (HpcInfo tickCount hashNo)
- = vcat
-    [ text "static void hpc_init_" <> ppr this_mod
-         <> text "(void) __attribute__((constructor));"
-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
-    , braces (vcat [
-        text "extern StgWord64 " <> tickboxes <>
-               text "[]" <> semi,
-        text "hs_hpc_module" <>
-          parens (hcat (punctuate comma [
-              doubleQuotes full_name_str,
-              int tickCount, -- really StgWord32
-              int hashNo,    -- really StgWord32
-              tickboxes
-            ])) <> semi
-       ])
-    ]
-  where
-    tickboxes = ppr (mkHpcTicksLabel $ this_mod)
-
-    module_name  = hcat (map (text.charToC) $ BS.unpack $
-                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
-    package_name = hcat (map (text.charToC) $ BS.unpack $
-                         bytesFS (unitIdFS  (moduleUnitId this_mod)))
-    full_name_str
-       | moduleUnitId this_mod == mainUnitId
-       = module_name
-       | otherwise
-       = package_name <> char '/' <> module_name