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)

3 files changed, 30 insertions, 15 deletions

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 9097e7fa12..4a11fc98d8 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -863,5 +863,6 @@ cgTick tick
        ; case tick of
            ProfNote   cc t p -> emitSetCCC cc t p
            HpcTick    m n    -> emit (mkTickBox dflags m n)
+           SourceNote s n    -> emitTick $ SourceNote s n
            _other            -> return () -- ignore
        }
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index 931b55624b..ef6540534b 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -18,6 +18,9 @@ module StgCmmExtCode (
         loopDecls,
         getEnv,
 
+        withName,
+        getName,
+
         newLocal,
         newLabel,
         newBlockId,
@@ -72,15 +75,15 @@ type Decls      = [(FastString,Named)]
 -- | Does a computation in the FCode monad, with a current environment
 --      and a list of local declarations. Returns the resulting list of declarations.
 newtype CmmParse a
-        = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
 
 type ExtCode = CmmParse ()
 
 returnExtFC :: a -> CmmParse a
-returnExtFC a   = EC $ \_ s -> return (s, a)
+returnExtFC a   = EC $ \_ _ s -> return (s, a)
 
 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
-thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
 
 instance Functor CmmParse where
       fmap = liftM
@@ -94,8 +97,8 @@ instance Monad CmmParse where
   return = returnExtFC
 
 instance HasDynFlags CmmParse where
-    getDynFlags = EC (\_ d -> do dflags <- getDynFlags
-                                 return (d, dflags))
+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
+                                   return (d, dflags))
 
 
 -- | Takes the variable decarations and imports from the monad
@@ -106,18 +109,25 @@ instance HasDynFlags CmmParse where
 --
 loopDecls :: CmmParse a -> CmmParse a
 loopDecls (EC fcode) =
-      EC $ \e globalDecls -> do
-        (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls)
+      EC $ \c e globalDecls -> do
+        (_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls)
         return (globalDecls, a)
 
 
 -- | Get the current environment from the monad.
 getEnv :: CmmParse Env
-getEnv  = EC $ \e s -> return (s, e)
+getEnv  = EC $ \_ e s -> return (s, e)
+
+-- | Get the current context name from the monad
+getName :: CmmParse String
+getName  = EC $ \c _ s -> return (s, c)
 
+-- | Set context name for a sub-parse
+withName :: String -> CmmParse a -> CmmParse a
+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
 
 addDecl :: FastString -> Named -> ExtCode
-addDecl name named = EC $ \_ s -> return ((name, named) : s, ())
+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
 
 
 -- | Add a new variable to the list of local declarations.
@@ -201,7 +211,7 @@ lookupName name = do
 
 -- | Lift an FCode computation into the CmmParse monad
 code :: FCode a -> CmmParse a
-code fc = EC $ \_ s -> do
+code fc = EC $ \_ _ s -> do
                 r <- fc
                 return (s, r)
 
@@ -218,13 +228,13 @@ emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
 emitStore l r = code (F.emitStore l r)
 
 getCode :: CmmParse a -> CmmParse CmmAGraph
-getCode (EC ec) = EC $ \e s -> do
-  ((s',_), gr) <- F.getCodeR (ec e s)
+getCode (EC ec) = EC $ \c e s -> do
+  ((s',_), gr) <- F.getCodeR (ec c e s)
   return (s', gr)
 
 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
-getCodeR (EC ec) = EC $ \e s -> do
-  ((s', r), gr) <- F.getCodeR (ec e s)
+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 ()
@@ -232,7 +242,7 @@ emitOutOfLine l g = code (F.emitOutOfLine l g)
 
 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
 withUpdFrameOff size inner
-  = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
 
 getUpdFrameOff :: CmmParse UpdFrameOffset
 getUpdFrameOff = code $ F.getUpdFrameOff
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 57120cf5ce..252a815ee6 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -20,6 +20,7 @@ module StgCmmMonad (
         emit, emitDecl, emitProc,
         emitProcWithConvention, emitProcWithStackFrame,
         emitOutOfLine, emitAssign, emitStore, emitComment,
+        emitTick,
 
         getCmm, aGraphToGraph,
         getCodeR, getCode, getHeapUsage,
@@ -683,6 +684,9 @@ emitComment s = emitCgStmt (CgStmt (CmmComment s))
 emitComment _ = return ()
 #endif
 
+emitTick :: CmmTickish -> FCode ()
+emitTick = emitCgStmt . CgStmt . CmmTick
+
 emitAssign :: CmmReg  -> CmmExpr -> FCode ()
 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))