Source notes (Cmm support)

This patch adds CmmTick nodes to Cmm code. This is relatively
straight-forward, but also not very useful, as many blocks will simply
end up with no annotations whatosever.

Notes:

* We use this design over, say, putting ticks into the entry node of all
  blocks, as it seems to work better alongside existing optimisations.
  Now granted, the reason for this is that currently GHC's main Cmm
  optimisations seem to mainly reorganize and merge code, so this might
  change in the future.

* We have the Cmm parser generate a few source notes as well. This is
  relatively easy to do - worst part is that it complicates the CmmParse
  implementation a bit.

(From Phabricator D169)

1 files changed, 23 insertions, 7 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 803333001c..0973e306b0 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -220,6 +220,7 @@ import StgCmmClosure
 import StgCmmLayout     hiding (ArgRep(..))
 import StgCmmTicky
 import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
+import CoreSyn          ( Tickish(SourceNote) )
 
 import CmmOpt
 import MkGraph
@@ -430,8 +431,10 @@ cmmproc :: { CmmParse () }
                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
                        getCodeR $ loopDecls $ do {
                          (entry_ret_label, info, stk_formals) <- $1;
+                         dflags <- getDynFlags;
                          formals <- sequence (fromMaybe [] $3);
-                         $4;
+                         withName (showSDoc dflags (ppr entry_ret_label))
+                           $4;
                          return (entry_ret_label, info, stk_formals, formals) }
                      let do_layout = isJust $3
                      code (emitProcWithStackFrame $2 info
@@ -444,7 +447,7 @@ maybe_conv :: { Convention }
 
 maybe_body :: { CmmParse () }
            : ';'                { return () }
-           | '{' body '}'       { $2 }
+           | '{' body '}'       { withSourceNote $1 $3 $2 }
 
 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
         : NAME
@@ -626,7 +629,7 @@ stmt    :: { CmmParse () }
         | 'if' bool_expr 'goto' NAME
                 { do l <- lookupLabel $4; cmmRawIf $2 l }
         | 'if' bool_expr '{' body '}' else      
-                { cmmIfThenElse $2 $4 $6 }
+                { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }
         | 'push' '(' exprs0 ')' maybe_body
                 { pushStackFrame $3 $5 }
         | 'reserve' expr '=' lreg maybe_body
@@ -679,7 +682,7 @@ arm     :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
 
 arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
-        : '{' body '}'                  { return (Right $2) }
+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
 
 ints    :: { [Int] }
@@ -687,7 +690,7 @@ ints    :: { [Int] }
         | INT ',' ints                  { fromIntegral $1 : $3 }
 
 default :: { Maybe (CmmParse ()) }
-        : 'default' ':' '{' body '}'    { Just $4 }
+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
         -- taking a few liberties with the C-- syntax here; C-- doesn't have
         -- 'default' branches
         | {- empty -}                   { Nothing }
@@ -696,7 +699,7 @@ default :: { Maybe (CmmParse ()) }
 -- CmmNode does.
 else    :: { CmmParse () }
         : {- empty -}                   { return () }
-        | 'else' '{' body '}'           { $3 }
+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
 
 -- we have to write this out longhand so that Happy's precedence rules
 -- can kick in.
@@ -1275,6 +1278,18 @@ emitCond (e1 `BoolAnd` e2) then_id = do
   emitCond e2 then_id
   emitLabel else_id
 
+-- -----------------------------------------------------------------------------
+-- Source code notes
+
+-- | Generate a source note spanning from "a" to "b" (inclusive), then
+-- proceed with parsing. This allows debugging tools to reason about
+-- locations in Cmm code.
+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
+withSourceNote a b parse = do
+  name <- getName
+  case combineSrcSpans (getLoc a) (getLoc b) of
+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
+    _other           -> parse
 
 -- -----------------------------------------------------------------------------
 -- Table jumps
@@ -1354,7 +1369,8 @@ parseCmmFile dflags filename = do
         return ((emptyBag, unitBag msg), Nothing)
     POk pst code -> do
         st <- initC
-        let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+            (cmm,_) = runC dflags no_module st fcode
         let ms = getMessages pst
         if (errorsFound dflags ms)
          then return (ms, Nothing)