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, 26 insertions, 24 deletions

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