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)

1 files changed, 67 insertions, 21 deletions

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) }