Tick scopes

This patch solves the scoping problem of CmmTick nodes: If we just put
CmmTicks into blocks we have no idea what exactly they are meant to
cover.  Here we introduce tick scopes, which allow us to create
sub-scopes and merged scopes easily.

Notes:

* Given that the code often passes Cmm around "head-less", we have to
  make sure that its intended scope does not get lost. To keep the amount
  of passing-around to a minimum we define a CmmAGraphScoped type synonym
  here that just bundles the scope with a portion of Cmm to be assembled
  later.

* We introduce new scopes at somewhat random places, aligning with
  getCode calls. This works surprisingly well, but we might have to
  add new scopes into the mix later on if we find things too be too
  coarse-grained.

(From Phabricator D169)

22 files changed, 349 insertions, 145 deletions

diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index e8fc5da50e..e009ce5171 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,7 +13,7 @@ import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl hiding (ChangeFlag)
 import Data.Bits
-import Data.Maybe (fromJust)
+import Data.Maybe (mapMaybe)
 import qualified Data.List as List
 import Data.Word
 import qualified Data.Map as M
@@ -221,11 +221,18 @@ eqMaybeWith _ _ _ = False
 copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 copyTicks env g
   | mapNull env = g
-  | otherwise   = ofBlockMap (g_entry g) $ mapMap f blockMap
-  where blockMap = toBlockMap g
+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
+  where -- Reverse block merge map
+        blockMap = toBlockMap g
         revEnv = mapFoldWithKey insertRev M.empty env
         insertRev k x = M.insertWith (const (k:)) x [k]
-        f block = case M.lookup (entryLabel block) revEnv of
+        -- Copy ticks and scopes into the given block
+        copyTo block = case M.lookup (entryLabel block) revEnv of
           Nothing -> block
-          Just ls -> let findTicks l = blockTicks $ fromJust $ mapLookup l blockMap
-                     in annotateBlock (concatMap findTicks ls) block
+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
+        copy from to =
+          let ticks = blockTicks from
+              CmmEntry  _   scp0        = firstNode from
+              (CmmEntry lbl scp1, code) = blockSplitHead to
+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
+             foldr blockCons code (map CmmTick ticks)
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 4b8ce6f0f3..bcb4cf97b3 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -317,18 +317,22 @@ decPreds bid edges = case mapLookup bid edges of
 canShortcut :: CmmBlock -> Maybe BlockId
 canShortcut block
     | (_, middle, CmmBranch dest) <- blockSplit block
-    , isEmptyBlock middle
+    , all dont_care $ blockToList middle
     = Just dest
     | otherwise
     = Nothing
-
+    where dont_care CmmComment{} = True
+          dont_care CmmTick{}    = True
+          dont_care _other       = False
 
 -- Concatenates two blocks. First one is assumed to be open on exit, the second
 -- is assumed to be closed on entry (i.e. it has a label attached to it, which
 -- the splice function removes by calling snd on result of blockSplitHead).
 splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
-splice head rest = head `blockAppend` snd (blockSplitHead rest)
-
+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
+  where (CmmEntry lbl sc0, code0) = blockSplitHead head
+        (CmmEntry _   sc1, code1) = blockSplitHead rest
+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)
 
 -- If node is a call with continuation call return Just label of that
 -- continuation. Otherwise return Nothing.
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5a2891fffc..7df0af6c68 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -240,7 +240,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
 
     go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
       = do
-       let (entry0@(CmmEntry entry_lbl), middle0, last0) = blockSplit b0
+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
 
        let stack0@StackMap { sm_sp = sp0 }
                = mapFindWithDefault
@@ -264,7 +264,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
        --     details.
        (middle2, sp_off, last1, fixup_blocks, out)
            <- handleLastNode dflags procpoints liveness cont_info
-                             acc_stackmaps stack1 middle0 last0
+                             acc_stackmaps stack1 tscope middle0 last0
 
        -- (d) Manifest Sp: run over the nodes in the block and replace
        --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
@@ -386,7 +386,7 @@ getStackLoc (Young l) n stackmaps =
 
 handleLastNode
    :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-   -> BlockEnv StackMap -> StackMap
+   -> BlockEnv StackMap -> StackMap -> CmmTickScope
    -> Block CmmNode O O
    -> CmmNode O C
    -> UniqSM
@@ -398,7 +398,7 @@ handleLastNode
       )
 
 handleLastNode dflags procpoints liveness cont_info stackmaps
-               stack0@StackMap { sm_sp = sp0 } middle last
+               stack0@StackMap { sm_sp = sp0 } tscp middle last
  = case last of
     --  At each return / tail call,
     --  adjust Sp to point to the last argument pushed, which
@@ -496,7 +496,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
         | Just stack2 <- mapLookup l stackmaps
         = do
              let assigs = fixupStack stack0 stack2
-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
              return (l, tmp_lbl, stack2, block)
 
         --   (b) if the successor is a proc point, save everything
@@ -507,7 +507,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
                  (stack2, assigs) =
                       setupStackFrame dflags l liveness (sm_ret_off stack0)
                                                         cont_args stack0
-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
              return (l, tmp_lbl, stack2, block)
 
         --   (c) otherwise, the current StackMap is the StackMap for
@@ -521,14 +521,15 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
               is_live (r,_) = r `elemRegSet` live
 
 
-makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O]
+makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
+               -> CmmTickScope -> [CmmNode O O]
                -> UniqSM (Label, [CmmBlock])
-makeFixupBlock dflags sp0 l stack assigs
+makeFixupBlock dflags sp0 l stack tscope assigs
   | null assigs && sp0 == sm_sp stack = return (l, [])
   | otherwise = do
     tmp_lbl <- liftM mkBlockId $ getUniqueM
     let sp_off = sp0 - sm_sp stack
-        block = blockJoin (CmmEntry tmp_lbl)
+        block = blockJoin (CmmEntry tmp_lbl tscope)
                           (maybeAddSpAdj dflags sp_off (blockFromList assigs))
                           (CmmBranch l)
     return (tmp_lbl, [block])
@@ -985,7 +986,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph.
 
 lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
 lowerSafeForeignCall dflags block
-  | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
   = do
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
@@ -1026,11 +1027,11 @@ lowerSafeForeignCall dflags block
                        , cml_ret_args  = ret_args
                        , cml_ret_off   = ret_off }
 
-    graph' <- lgraphOfAGraph $ suspend <*>
+    graph' <- lgraphOfAGraph ( suspend <*>
                                midCall <*>
                                resume  <*>
                                copyout <*>
-                               mkLast jump
+                               mkLast jump, tscp)
 
     case toBlockList graph' of
       [one] -> let (_, middle', last) = blockSplit one
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 50268ee8be..2376b422a6 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -15,7 +15,10 @@ module CmmNode (
      ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
      CmmReturnInfo(..),
      mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
-     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
+
+     -- * Tick scopes
+     CmmTickScope(..), isTickSubScope, combineTickScopes,
   ) where
 
 import CodeGen.Platform
@@ -23,12 +26,14 @@ import CmmExpr
 import DynFlags
 import FastString
 import ForeignCall
+import Outputable
 import SMRep
 import CoreSyn (Tickish)
+import qualified Unique as U
 
 import Compiler.Hoopl
 import Data.Maybe
-import Data.List (tails)
+import Data.List (tails,sort)
 import Prelude hiding (succ)
 
 
@@ -38,12 +43,13 @@ import Prelude hiding (succ)
 #define ULabel {-# UNPACK #-} !Label
 
 data CmmNode e x where
-  CmmEntry :: ULabel -> CmmNode C O
+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
 
   CmmComment :: FastString -> CmmNode O O
 
     -- Tick annotation, covering Cmm code in our tick scope. We only
     -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
+    -- See Note [CmmTick scoping details]
   CmmTick :: !CmmTickish -> CmmNode O O
 
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
@@ -211,7 +217,7 @@ deriving instance Eq (CmmNode e x)
 -- Hoopl instances of CmmNode
 
 instance NonLocal CmmNode where
-  entryLabel (CmmEntry l) = l
+  entryLabel (CmmEntry l _) = l
 
   successors (CmmBranch l) = [l]
   successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
@@ -440,7 +446,7 @@ wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 wrapRecExp f e                    = f e
 
 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
-mapExp _ f@(CmmEntry _)                          = f
+mapExp _ f@(CmmEntry{})                          = f
 mapExp _ m@(CmmComment _)                        = m
 mapExp _ m@(CmmTick _)                           = m
 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
@@ -470,7 +476,7 @@ wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecE
 wrapRecExpM f e                    = f e
 
 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
-mapExpM _ (CmmEntry _)              = Nothing
+mapExpM _ (CmmEntry{})              = Nothing
 mapExpM _ (CmmComment _)            = Nothing
 mapExpM _ (CmmTick _)               = Nothing
 mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
@@ -549,3 +555,120 @@ mapSuccessors _ n = n
 
 -- | Tickish in Cmm context (annotations only)
 type CmmTickish = Tickish ()
+
+-- | Tick scope identifier, allowing us to reason about what
+-- annotations in a Cmm block should scope over. We especially take
+-- care to allow optimisations to reorganise blocks without losing
+-- tick association in the process.
+data CmmTickScope
+  = GlobalScope
+    -- ^ The global scope is the "root" of the scope graph. Every
+    -- scope is a sub-scope of the global scope. It doesn't make sense
+    -- to add ticks to this scope. On the other hand, this means that
+    -- setting this scope on a block means no ticks apply to it.
+
+  | SubScope U.Unique CmmTickScope
+    -- ^ Constructs a new sub-scope to an existing scope. This allows
+    -- us to translate Core-style scoping rules (see @tickishScoped@)
+    -- into the Cmm world. Suppose the following code:
+    --
+    --   tick<1> case ... of
+    --             A -> tick<2> ...
+    --             B -> tick<3> ...
+    --
+    -- We want the top-level tick annotation to apply to blocks
+    -- generated for the A and B alternatives. We can achieve that by
+    -- generating tick<1> into a block with scope a, while the code
+    -- for alternatives A and B gets generated into sub-scopes a/b and
+    -- a/c respectively.
+
+  | CombinedScope CmmTickScope CmmTickScope
+    -- ^ A combined scope scopes over everything that the two given
+    -- scopes cover. It is therefore a sub-scope of either scope. This
+    -- is required for optimisations. Consider common block elimination:
+    --
+    --   A -> tick<2> case ... of
+    --     C -> [common]
+    --   B -> tick<3> case ... of
+    --     D -> [common]
+    --
+    -- We will generate code for the C and D alternatives, and figure
+    -- out afterwards that it's actually common code. Scoping rules
+    -- dictate that the resulting common block needs to be covered by
+    -- both tick<2> and tick<3>, therefore we need to construct a
+    -- scope that is a child to *both* scope. Now we can do that - if
+    -- we assign the scopes a/c and b/d to the common-ed up blocks,
+    -- the new block could have a combined tick scope a/c+b/d, which
+    -- both tick<2> and tick<3> apply to.
+
+-- Note [CmmTick scoping details]:
+--
+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
+-- same block. Note that as a result of this, optimisations making
+-- tick scopes more specific can *reduce* the amount of code a tick
+-- scopes over. Fixing this would require a separate @CmmTickScope@
+-- field for @CmmTick@. Right now we do not do this simply because I
+-- couldn't find an example where it actually mattered -- multiple
+-- blocks within the same scope generally jump to each other, which
+-- prevents common block elimination from happening in the first
+-- place. But this is no strong reason, so if Cmm optimisations become
+-- more involved in future this might have to be revisited.
+
+-- | Output all scope paths.
+scopeToPaths :: CmmTickScope -> [[U.Unique]]
+scopeToPaths GlobalScope           = [[]]
+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+
+-- | Returns the head uniques of the scopes. This is based on the
+-- assumption that the @Unique@ of @SubScope@ identifies the
+-- underlying super-scope. Used for efficient equality and comparison,
+-- see below.
+scopeUniques :: CmmTickScope -> [U.Unique]
+scopeUniques GlobalScope           = []
+scopeUniques (SubScope u _)        = [u]
+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+
+-- Equality and order is based on the head uniques defined above. We
+-- take care to short-cut the (extremly) common cases.
+instance Eq CmmTickScope where
+  GlobalScope    == GlobalScope     = True
+  GlobalScope    == _               = False
+  _              == GlobalScope     = False
+  (SubScope u _) == (SubScope u' _) = u == u'
+  (SubScope _ _) == _               = False
+  _              == (SubScope _ _)  = False
+  scope          == scope'          = sort (scopeUniques scope) ==
+                                      sort (scopeUniques scope')
+instance Ord CmmTickScope where
+  compare GlobalScope    GlobalScope     = EQ
+  compare GlobalScope    _               = LT
+  compare _              GlobalScope     = GT
+  compare (SubScope u _) (SubScope u' _) = compare u u'
+  compare scope scope'                   = compare (sort $ scopeUniques scope)
+                                                   (sort $ scopeUniques scope')
+
+instance Outputable CmmTickScope where
+  ppr GlobalScope     = text "global"
+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us
+  ppr combined        = parens $ hcat $ punctuate (char '+') $
+                        map (hcat . punctuate (char '/') . map ppr . reverse) $
+                        scopeToPaths combined
+
+-- | Checks whether two tick scopes are sub-scopes of each other. True
+-- if the two scopes are equal.
+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
+isTickSubScope = cmp
+  where cmp _              GlobalScope             = True
+        cmp GlobalScope    _                       = False
+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'
+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'
+
+-- | Combine two tick scopes. This smart constructor will catch cases
+-- where one tick scope is a sub-scope of the other already.
+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
+combineTickScopes s1 s2
+  | s1 `isTickSubScope` s2 = s2
+  | s2 `isTickSubScope` s1 = s1
+  | otherwise              = CombinedScope s1 s2
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 0973e306b0..c911606825 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -209,7 +209,7 @@ import StgCmmExtCode
 import CmmCallConv
 import StgCmmProf
 import StgCmmHeap
-import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
+import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
                           , emitAssign, emitOutOfLine, withUpdFrameOff
                           , getUpdFrameOff )
 import qualified StgCmmMonad as F
@@ -429,7 +429,7 @@ lits    :: { [CmmParse CmmExpr] }
 cmmproc :: { CmmParse () }
         : info maybe_conv maybe_formals maybe_body
                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
-                       getCodeR $ loopDecls $ do {
+                       getCodeScoped $ loopDecls $ do {
                          (entry_ret_label, info, stk_formals) <- $1;
                          dflags <- getDynFlags;
                          formals <- sequence (fromMaybe [] $3);
@@ -1336,7 +1336,7 @@ doSwitch mb_range scrut arms deflt
 
 forkLabelledCode :: CmmParse () -> CmmParse BlockId
 forkLabelledCode p = do
-  ag <- getCode p
+  (_,ag) <- getCodeScoped p
   l <- newBlockId
   emitOutOfLine l ag
   return l
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 5f9c27fe7a..2add4741ef 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -145,7 +145,7 @@ forward :: FwdTransfer CmmNode Status
 forward = mkFTransfer3 first middle last
     where
       first :: CmmNode C O -> Status -> Status
-      first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
+      first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id
       first  _ x = x
 
       middle _ x = x
@@ -282,7 +282,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      -- and replace branches to procpoints with branches to the jump-off blocks
      let add_jump_block (env, bs) (pp, l) =
            do bid <- liftM mkBlockId getUniqueM
-              let b = blockJoin (CmmEntry bid) emptyBlock jump
+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
                   live = ppLiveness pp
                   jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
               return (mapInsert pp bid env, b : bs)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 043ccf0ff5..65d633e6b7 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -58,7 +58,7 @@ module CmmUtils(
         dataflowAnalFwdBlocks,
 
         -- * Ticks
-        blockTicks, annotateBlock
+        blockTicks
   ) where
 
 #include "HsVersions.h"
@@ -496,7 +496,8 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
                  , CmmNode O C -> CmmNode O C)
               -> CmmGraph -> CmmGraph
 mapGraphNodes funs@(mf,_,_) g =
-  ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (mapBlock3' funs) $ toBlockMap g
+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
+  mapMap (mapBlock3' funs) $ toBlockMap g
 
 mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
 mapGraphNodes1 f = modifyGraph (mapGraph f)
@@ -580,8 +581,3 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
   where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
         goStmt  (CmmTick t) ts = t:ts
         goStmt  _other      ts = ts
-
-annotateBlock :: [CmmTickish] -> Block CmmNode C C -> Block CmmNode C C
-annotateBlock ts b = blockJoin hd (tstmts `blockAppend` mid) tl
-  where (hd, mid, tl) = blockSplit b
-        tstmts = foldr blockCons emptyBlock $ map CmmTick ts
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 9bc2bd9ddc..064577cd0a 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE BangPatterns, CPP, GADTs #-}
 
 module MkGraph
-  ( CmmAGraph, CgStmt(..)
+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
   , (<*>), catAGraphs
   , mkLabel, mkMiddle, mkLast, outOfLine
   , lgraphOfAGraph, labelAGraph
@@ -58,22 +58,24 @@ import Prelude (($),Int,Eq(..)) -- avoid importing (<*>)
 -- control flows from the first to the second.
 --
 -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
--- by providing a label for the entry point; see 'labelAGraph'.
---
+-- by providing a label for the entry point and a tick scope; see
+-- 'labelAGraph'.
 type CmmAGraph = OrdList CgStmt
+-- | Unlabeled graph with tick scope
+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
 
 data CgStmt
-  = CgLabel BlockId
+  = CgLabel BlockId CmmTickScope
   | CgStmt  (CmmNode O O)
   | CgLast  (CmmNode O C)
-  | CgFork  BlockId CmmAGraph
+  | CgFork  BlockId CmmAGraph CmmTickScope
 
-flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph
-flattenCmmAGraph id stmts =
+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
+flattenCmmAGraph id (stmts_t, tscope) =
     CmmGraph { g_entry = id,
                g_graph = GMany NothingO body NothingO }
   where
-  body = foldr addBlock emptyBody $ flatten id stmts []
+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
 
   --
   -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
@@ -81,10 +83,11 @@ flattenCmmAGraph id stmts =
   -- NB. avoid the quadratic-append trap by passing in the tail of the
   -- list.  This is important for Very Long Functions (e.g. in T783).
   --
-  flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C]
-  flatten id g blocks
-      = flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks
-
+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
+          -> [Block CmmNode C C]
+  flatten id g tscope blocks
+      = flatten1 (fromOL g) block' blocks
+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
   --
   -- flatten0: we are outside a block at this point: any code before
   -- the first label is unreachable, so just drop it.
@@ -92,12 +95,12 @@ flattenCmmAGraph id stmts =
   flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
   flatten0 [] blocks = blocks
 
-  flatten0 (CgLabel id : stmts) blocks
+  flatten0 (CgLabel id tscope : stmts) blocks
     = flatten1 stmts block blocks
-    where !block = blockJoinHead (CmmEntry id) emptyBlock
+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
 
-  flatten0 (CgFork fork_id stmts : rest) blocks
-    = flatten fork_id stmts $ flatten0 rest blocks
+  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks
 
   flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
   flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
@@ -127,14 +130,14 @@ flattenCmmAGraph id stmts =
     = flatten1 stmts block' blocks
     where !block' = blockSnoc block stmt
 
-  flatten1 (CgFork fork_id stmts : rest) block blocks
-    = flatten fork_id stmts $ flatten1 rest block blocks
+  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
 
   -- a label here means that we should start a new block, and the
   -- current block should fall through to the new block.
-  flatten1 (CgLabel id : stmts) block blocks
+  flatten1 (CgLabel id tscp : stmts) block blocks
     = blockJoinTail block (CmmBranch id) :
-      flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks
+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
 
 
 
@@ -147,8 +150,8 @@ catAGraphs     :: [CmmAGraph] -> CmmAGraph
 catAGraphs      = concatOL
 
 -- | created a sequence "goto id; id:" as an AGraph
-mkLabel        :: BlockId -> CmmAGraph
-mkLabel bid     = unitOL (CgLabel bid)
+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
+mkLabel bid scp = unitOL (CgLabel bid scp)
 
 -- | creates an open AGraph from a given node
 mkMiddle        :: CmmNode O O -> CmmAGraph
@@ -159,16 +162,17 @@ mkLast         :: CmmNode O C -> CmmAGraph
 mkLast last     = unitOL (CgLast last)
 
 -- | A labelled code block; should end in a last node
-outOfLine      :: BlockId -> CmmAGraph -> CmmAGraph
-outOfLine l g   = unitOL (CgFork l g)
+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
+outOfLine l (c,s) = unitOL (CgFork l c s)
 
 -- | allocate a fresh label for the entry point
-lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
-lgraphOfAGraph g = do u <- getUniqueM
-                      return (labelAGraph (mkBlockId u) g)
+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
+lgraphOfAGraph g = do
+  u <- getUniqueM
+  return (labelAGraph (mkBlockId u) g)
 
 -- | use the given BlockId as the label of the entry point
-labelAGraph    :: BlockId -> CmmAGraph -> CmmGraph
+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
 labelAGraph lbl ag = flattenCmmAGraph lbl ag
 
 ---------- No-ops
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index d808341304..a2c3abf320 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -138,10 +138,10 @@ pprTop (CmmData _section (Statics lbl lits)) =
 
 pprBBlock :: CmmBlock -> SDoc
 pprBBlock block =
-  nest 4 (pprBlockId lbl <> colon) $$
+  nest 4 (pprBlockId (entryLabel block) <> colon) $$
   nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
  where
-  (CmmEntry lbl, nodes, last)  = blockSplit block
+  (_, nodes, last)  = blockSplit block
 
 -- --------------------------------------------------------------------------
 -- Info tables. Just arrays of words.
@@ -171,7 +171,7 @@ pprStmt :: CmmNode e x -> SDoc
 pprStmt stmt =
     sdocWithDynFlags $ \dflags ->
     case stmt of
-    CmmEntry _ -> empty
+    CmmEntry{}   -> empty
     CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
                           -- XXX if the string contains "*/", we need to fix it
                           -- XXX we probably want to emit these comments when
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index f350a8a5f9..23982127a0 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -183,7 +183,9 @@ pprNode node = pp_node <+> pp_debug
     pp_node :: SDoc
     pp_node = sdocWithDynFlags $ \dflags -> case node of
       -- label:
-      CmmEntry id -> ppr id <> colon
+      CmmEntry id tscope -> ppr id <> colon <+>
+         (sdocWithDynFlags $ \dflags ->
+           ppWhen (gopt Opt_PprShowTicks dflags) (text "//" <+> ppr tscope))
 
       -- // text
       CmmComment s -> text "//" <+> ftext s
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 3c17160750..da87f965d5 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -553,7 +553,9 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
                                 (mkLblExpr fast_lbl)
                                 (map (CmmReg . CmmLocal) (node : arg_regs))
                                 (initUpdFrameOff dflags)
-       emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) jump
+       tscope <- getTickScope
+       emitProcWithConvention Slow Nothing slow_lbl
+         (node : arg_regs) (jump, tscope)
   | otherwise = return ()
 
 -----------------------------------------
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 4a11fc98d8..ee635508fb 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -47,6 +47,7 @@ import FastString
 import Outputable
 
 import Control.Monad (when,void)
+import Control.Arrow (first)
 
 #if __GLASGOW_HASKELL__ >= 709
 import Prelude hiding ((<*>))
@@ -130,8 +131,8 @@ cgLetNoEscapeRhs
 cgLetNoEscapeRhs join_id local_cc bndr rhs =
   do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; let code = do { body <- getCode rhs_code
-                     ; emitOutOfLine bid (body <*> mkBranch join_id) }
+     ; let code = do { (_, body) <- getCodeScoped rhs_code
+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }
      ; return (info, code)
      }
 
@@ -588,8 +589,8 @@ cgAlts _ _ _ _ = panic "cgAlts"
 
 -------------------
 cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
-             -> FCode ( Maybe CmmAGraph
-                      , [(ConTagZ, CmmAGraph)] )
+             -> FCode ( Maybe CmmAGraphScoped
+                      , [(ConTagZ, CmmAGraphScoped)] )
 cgAlgAltRhss gc_plan bndr alts
   = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
 
@@ -608,14 +609,14 @@ cgAlgAltRhss gc_plan bndr alts
 
 -------------------
 cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
-          -> FCode [(AltCon, CmmAGraph)]
+          -> FCode [(AltCon, CmmAGraphScoped)]
 cgAltRhss gc_plan bndr alts = do
   dflags <- getDynFlags
   let
     base_reg = idToReg dflags bndr
-    cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph)
+    cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped)
     cg_alt (con, bndrs, _uses, rhs)
-      = getCodeR                  $
+      = getCodeScoped             $
         maybeAltHeapCheck gc_plan $
         do { _ <- bindConArgs con base_reg bndrs
            ; _ <- cgExpr rhs
@@ -840,11 +841,12 @@ emitEnter fun = do
          -- inlined in the RHS of the R1 assignment.
        ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
              the_call = toCall entry (Just lret) updfr_off off outArgs regs
+       ; tscope <- getTickScope
        ; emit $
            copyout <*>
            mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*>
-           outOfLine lcall the_call <*>
-           mkLabel lret <*>
+           outOfLine lcall (the_call,tscope) <*>
+           mkLabel lret tscope <*>
            copyin
        ; return (ReturnedTo lret off)
        }
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index ef6540534b..03f6a47d87 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -31,7 +31,7 @@ module StgCmmExtCode (
 
         code,
         emit, emitLabel, emitAssign, emitStore,
-        getCode, getCodeR,
+        getCode, getCodeR, getCodeScoped,
         emitOutOfLine,
         withUpdFrameOff, getUpdFrameOff
 )
@@ -110,7 +110,8 @@ instance HasDynFlags CmmParse where
 loopDecls :: CmmParse a -> CmmParse a
 loopDecls (EC fcode) =
       EC $ \c e globalDecls -> do
-        (_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls)
+        (_, a) <- F.fixC $ \ ~(decls, _) ->
+          fcode c (addListToUFM e decls) globalDecls
         return (globalDecls, a)
 
 
@@ -219,7 +220,7 @@ emit :: CmmAGraph -> CmmParse ()
 emit = code . F.emit
 
 emitLabel :: BlockId -> CmmParse ()
-emitLabel = code. F.emitLabel
+emitLabel = code . F.emitLabel
 
 emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
 emitAssign l r = code (F.emitAssign l r)
@@ -237,7 +238,12 @@ getCodeR (EC ec) = EC $ \c e s -> do
   ((s', r), gr) <- F.getCodeR (ec c e s)
   return (s', (r,gr))
 
-emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
+getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
+getCodeScoped (EC ec) = EC $ \c e s -> do
+  ((s', r), gr) <- F.getCodeScoped (ec c e s)
+  return (s', (r,gr))
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
 emitOutOfLine l g = code (F.emitOutOfLine l g)
 
 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index c2e276ed0b..c38519ed13 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -228,6 +228,7 @@ emitForeignCall safety results target args
     k <- newLabelC
     let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
        -- see Note [safe foreign call convention]
+    tscope <- getTickScope
     emit $
            (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
                         (CmmLit (CmmBlock k))
@@ -238,7 +239,7 @@ emitForeignCall safety results target args
                                        , ret_args = off
                                        , ret_off = updfr_off
                                        , intrbl = playInterruptible safety })
-            <*> mkLabel k
+            <*> mkLabel k tscope
             <*> copyout
            )
     return (ReturnedTo k off)
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index eca118fd25..0e9eb6d658 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -420,7 +420,8 @@ altOrNoEscapeHeapCheck checkYield regs code = do
         lret <- newLabelC
         let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
         lcont <- newLabelC
-        emitOutOfLine lret (copyin <*> mkBranch lcont)
+        tscope <- getTickScope
+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
         emitLabel lcont
         cannedGCReturnsTo checkYield False gc regs lret off code
 
@@ -651,8 +652,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
                                    CmmLit (zeroCLit dflags)]
          emit =<< mkCmmIfGoto yielding gc_id
 
-  emitOutOfLine gc_id $
-     do_gc -- this is expected to jump back somewhere
+  tscope <- getTickScope
+  emitOutOfLine gc_id
+   (do_gc, tscope) -- this is expected to jump back somewhere
 
                 -- Test for stack pointer exhaustion, then
                 -- bump heap pointer, and test for heap exhaustion
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index af2d6619ea..c3d8873cfb 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -120,7 +120,8 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
                   (off, _, copyin) = copyInOflow dflags retConv area res_regs []
                   copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
                                    extra_stack
-              emit (copyout <*> mkLabel k <*> copyin)
+              tscope <- getTickScope
+              emit (copyout <*> mkLabel k tscope <*> copyin)
               return (ReturnedTo k off)
       }
 
@@ -224,15 +225,16 @@ slowCall fun stg_args
              let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
                                                   (mkIntExpr dflags n_args)
 
+             tscope <- getTickScope
              emit (mkCbranch (cmmIsTagged dflags funv) is_tagged_lbl slow_lbl
-                   <*> mkLabel is_tagged_lbl
+                   <*> mkLabel is_tagged_lbl tscope
                    <*> mkCbranch correct_arity fast_lbl slow_lbl
-                   <*> mkLabel fast_lbl
+                   <*> mkLabel fast_lbl tscope
                    <*> fast_code
                    <*> mkBranch end_lbl
-                   <*> mkLabel slow_lbl
+                   <*> mkLabel slow_lbl tscope
                    <*> slow_code
-                   <*> mkLabel end_lbl)
+                   <*> mkLabel end_lbl tscope)
              return r
 
            else do
@@ -536,7 +538,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
 emitClosureAndInfoTable ::
   CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
 emitClosureAndInfoTable info_tbl conv args body
-  = do { blks <- getCode body
+  = do { (_, blks) <- getCodeScoped body
        ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
        ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
        }
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 252a815ee6..cf78d512cc 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -23,7 +23,7 @@ module StgCmmMonad (
         emitTick,
 
         getCmm, aGraphToGraph,
-        getCodeR, getCode, getHeapUsage,
+        getCodeR, getCode, getCodeScoped, getHeapUsage,
 
         mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
         mkCall, mkCmmCall,
@@ -36,6 +36,7 @@ module StgCmmMonad (
         withSequel, getSequel,
 
         setTickyCtrLabel, getTickyCtrLabel,
+        tickScope, getTickScope,
 
         withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
 
@@ -181,10 +182,11 @@ data CgInfoDownwards        -- information only passed *downwards* by the monad
         cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame
         cgd_ticky     :: CLabel,            -- Current destination for ticky counts
         cgd_sequel    :: Sequel,            -- What to do at end of basic block
-        cgd_self_loop :: Maybe SelfLoopInfo -- Which tail calls can be compiled
+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled
                                             -- as local jumps? See Note
                                             -- [Self-recursive tail calls] in
                                             -- StgCmmExpr
+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks
   }
 
 type CgBindings = IdEnv CgIdInfo
@@ -305,7 +307,8 @@ initCgInfoDown dflags mod
                  , cgd_updfr_off = initUpdFrameOff dflags
                  , cgd_ticky     = mkTopTickyCtrLabel
                  , cgd_sequel    = initSequel
-                 , cgd_self_loop = Nothing }
+                 , cgd_self_loop = Nothing
+                 , cgd_tick_scope= GlobalScope }
 
 initSequel :: Sequel
 initSequel = Return False
@@ -557,6 +560,27 @@ setTickyCtrLabel ticky code = do
         info <- getInfoDown
         withInfoDown code (info {cgd_ticky = ticky})
 
+-- ----------------------------------------------------------------------------
+-- Manage tick scopes
+
+-- | The current tick scope. We will assign this to generated blocks.
+getTickScope :: FCode CmmTickScope
+getTickScope = do
+        info <- getInfoDown
+        return (cgd_tick_scope info)
+
+-- | Places blocks generated by the given code into a fresh
+-- (sub-)scope. This will make sure that Cmm annotations in our scope
+-- will apply to the Cmm blocks generated therein - but not the other
+-- way around.
+tickScope :: FCode a -> FCode a
+tickScope code = do
+        info <- getInfoDown
+        if not (gopt Opt_Debug (cgd_dflags info)) then code else do
+          u <- newUnique
+          let scope' = SubScope u (cgd_tick_scope info)
+          withInfoDown code info{ cgd_tick_scope = scope' }
+
 
 --------------------------------------------------------
 --                 Forking
@@ -645,6 +669,20 @@ getCodeR fcode
 getCode :: FCode a -> FCode CmmAGraph
 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
 
+-- | Generate code into a fresh tick (sub-)scope and gather generated code
+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
+getCodeScoped fcode
+  = do  { state1 <- getState
+        ; ((a, tscope), state2) <-
+            tickScope $
+            flip withState state1 { cgs_stmts = mkNop } $
+            do { a   <- fcode
+               ; scp <- getTickScope
+               ; return (a, scp) }
+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
+        ; return (a, (cgs_stmts state2, tscope)) }
+
+
 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
 -- It initialises the heap usage to zeros, and passes on an unchanged
 -- heap usage.
@@ -675,7 +713,8 @@ emitCgStmt stmt
         }
 
 emitLabel :: BlockId -> FCode ()
-emitLabel id = emitCgStmt (CgLabel id)
+emitLabel id = do tscope <- getTickScope
+                  emitCgStmt (CgLabel id tscope)
 
 emitComment :: FastString -> FCode ()
 #if 0 /* def DEBUG */
@@ -708,8 +747,8 @@ emitDecl decl
   = do  { state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
 
-emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
-emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
 
 emitProcWithStackFrame
    :: Convention                        -- entry convention
@@ -717,7 +756,7 @@ emitProcWithStackFrame
    -> CLabel                            -- label for the proc
    -> [CmmFormal]                       -- stack frame
    -> [CmmFormal]                       -- arguments
-   -> CmmAGraph                         -- code
+   -> CmmAGraphScoped                   -- code
    -> Bool                              -- do stack layout?
    -> FCode ()
 
@@ -725,26 +764,29 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
   = do  { dflags <- getDynFlags
         ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
         }
-emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
+        -- do layout
   = do  { dflags <- getDynFlags
         ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
-        ; emitProc_ mb_info lbl live (entry MkGraph.<*> blocks) offset True
+              graph' = entry MkGraph.<*> graph
+        ; emitProc_ mb_info lbl live (graph', tscope) offset True
         }
 emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
 
 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
                        -> [CmmFormal]
-                       -> CmmAGraph
+                       -> CmmAGraphScoped
                        -> FCode ()
 emitProcWithConvention conv mb_info lbl args blocks
   = emitProcWithStackFrame conv mb_info lbl [] args blocks True
 
-emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+         -> Int -> FCode ()
 emitProc  mb_info lbl live blocks offset
  = emitProc_ mb_info lbl live blocks offset True
 
-emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
-          -> FCode ()
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+          -> Int -> Bool -> FCode ()
 emitProc_ mb_info lbl live blocks offset do_layout
   = do  { dflags <- getDynFlags
         ; l <- newLabelC
@@ -779,24 +821,27 @@ getCmm code
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
 mkCmmIfThenElse e tbranch fbranch = do
+  tscp  <- getTickScope
   endif <- newLabelC
   tid   <- newLabelC
   fid   <- newLabelC
-  return $ mkCbranch e tid fid MkGraph.<*>
-            mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkBranch endif MkGraph.<*>
-            mkLabel fid MkGraph.<*> fbranch MkGraph.<*> mkLabel endif
+  return $ catAGraphs [ mkCbranch e tid fid
+                      , mkLabel tid tscp, tbranch, mkBranch endif
+                      , mkLabel fid tscp, fbranch, mkLabel endif tscp ]
 
 mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
 mkCmmIfGoto e tid = do
   endif <- newLabelC
-  return $ mkCbranch e tid endif MkGraph.<*> mkLabel endif
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif, mkLabel endif tscp ]
 
 mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
 mkCmmIfThen e tbranch = do
   endif <- newLabelC
   tid   <- newLabelC
-  return $ mkCbranch e tid endif MkGraph.<*>
-         mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkLabel endif
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif
+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
 
 
 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
@@ -804,10 +849,11 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
   dflags <- getDynFlags
   k      <- newLabelC
+  tscp   <- getTickScope
   let area = Young k
       (off, _, copyin) = copyInOflow dflags retConv area results []
       copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
-  return (copyout MkGraph.<*> mkLabel k MkGraph.<*> copyin)
+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]
 
 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
           -> FCode CmmAGraph
@@ -818,7 +864,7 @@ mkCmmCall f results actuals updfr_off
 -- ----------------------------------------------------------------------------
 -- turn CmmAGraph into CmmGraph, for making a new proc.
 
-aGraphToGraph :: CmmAGraph -> FCode CmmGraph
+aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
 aGraphToGraph stmts
   = do  { l <- newLabelC
         ; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index d47a01661a..5e8944df4a 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -453,11 +453,12 @@ mustFollow :: Stmt -> Stmt -> Bool
 -------------------------------------------------------------------------
 
 
-emitSwitch :: CmmExpr                -- Tag to switch on
-           -> [(ConTagZ, CmmAGraph)] -- Tagged branches
-           -> Maybe CmmAGraph        -- Default branch (if any)
-           -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
-                                     -- outside this range is undefined
+emitSwitch :: CmmExpr                      -- Tag to switch on
+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+           -> Maybe CmmAGraphScoped        -- Default branch (if any)
+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
+                                           -- behaviour outside this range is
+                                           -- undefined
            -> FCode ()
 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
   = do  { dflags <- getDynFlags
@@ -467,18 +468,19 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
                  | otherwise                = False
 
 
-mkCmmSwitch :: Bool                   -- True <=> never generate a
-                                      -- conditional tree
-            -> CmmExpr                -- Tag to switch on
-            -> [(ConTagZ, CmmAGraph)] -- Tagged branches
-            -> Maybe CmmAGraph        -- Default branch (if any)
-            -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
-                                      -- outside this range is undefined
+mkCmmSwitch :: Bool                         -- True <=> never generate a
+                                            -- conditional tree
+            -> CmmExpr                      -- Tag to switch on
+            -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+            -> Maybe CmmAGraphScoped        -- Default branch (if any)
+            -> ConTagZ -> ConTagZ           -- Min and Max possible values;
+                                            -- behaviour outside this range is
+                                            -- undefined
             -> FCode ()
 
 -- First, two rather common cases in which there is no work to do
-mkCmmSwitch _ _ []         (Just code) _ _ = emit code
-mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = emit code
+mkCmmSwitch _ _ []         (Just code) _ _ = emit (fst code)
+mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = emit (fst code)
 
 -- Right, off we go
 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
@@ -634,17 +636,17 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
     is_lo (t,_) = t < mid_tag
 
 --------------
-emitCmmLitSwitch :: CmmExpr               -- Tag to switch on
-               -> [(Literal, CmmAGraph)]  -- Tagged branches
-               -> CmmAGraph               -- Default branch (always)
-               -> FCode ()                -- Emit the code
+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
+               -> CmmAGraphScoped              -- Default branch (always)
+               -> FCode ()                     -- Emit the code
 -- Used for general literals, whose size might not be a word,
 -- where there is always a default case, and where we don't know
 -- the range of values for certain.  For simplicity we always generate a tree.
 --
 -- ToDo: for integers we could do better here, perhaps by generalising
 -- mk_switch and using that.  --SDM 15/09/2004
-emitCmmLitSwitch _scrut []       deflt = emit deflt
+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt
 emitCmmLitSwitch scrut  branches deflt = do
     scrut' <- assignTemp' scrut
     join_lbl <- newLabelC
@@ -685,7 +687,7 @@ mk_lit_switch scrut deflt_blk_id branches
 
 
 --------------
-label_default :: BlockId -> Maybe CmmAGraph -> FCode (Maybe BlockId)
+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
 label_default _ Nothing
   = return  Nothing
 label_default join_lbl (Just code)
@@ -693,7 +695,7 @@ label_default join_lbl (Just code)
        return (Just lbl)
 
 --------------
-label_branches :: BlockId -> [(a,CmmAGraph)] -> FCode [(a,BlockId)]
+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
 label_branches _join_lbl []
   = return []
 label_branches join_lbl ((tag,code):branches)
@@ -702,14 +704,14 @@ label_branches join_lbl ((tag,code):branches)
        return ((tag,lbl):branches')
 
 --------------
-label_code :: BlockId -> CmmAGraph -> FCode BlockId
+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
 --  label_code J code
 --      generates
 --  [L: code; goto J]
 -- and returns L
-label_code join_lbl code = do
+label_code join_lbl (code,tsc) = do
     lbl <- newLabelC
-    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl)
+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
     return lbl
 
 --------------
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 42498fcefb..5a2f90acaf 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -74,7 +74,8 @@ basicBlocksCodeGen live (entryBlock:cmmBlocks)
 -- | Generate code for one block
 basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
 basicBlockCodeGen block
-  = do let (CmmEntry id, nodes, tail)  = blockSplit block
+  = do let (_, nodes, tail)  = blockSplit block
+           id = entryLabel block
        (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
        (tail_instrs, top')  <- stmtToInstrs tail
        let instrs = fromOL (mid_instrs `appOL` tail_instrs)
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 30f04e243e..c04814d2fe 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -95,7 +95,8 @@ basicBlockCodeGen
                 , [NatCmmDecl CmmStatics Instr])
 
 basicBlockCodeGen block = do
-  let (CmmEntry id, nodes, tail)  = blockSplit block
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
       stmts = blockToList nodes
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 836ba70f90..14855ed7fd 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -87,7 +87,8 @@ basicBlockCodeGen :: CmmBlock
                           , [NatCmmDecl CmmStatics Instr])
 
 basicBlockCodeGen block = do
-  let (CmmEntry id, nodes, tail)  = blockSplit block
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
       stmts = blockToList nodes
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 9e705c87f9..7c0ba2d4da 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -111,7 +111,8 @@ basicBlockCodeGen
                 , [NatCmmDecl (Alignment, CmmStatics) Instr])
 
 basicBlockCodeGen block = do
-  let (CmmEntry id, nodes, tail)  = blockSplit block
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
       stmts = blockToList nodes
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail