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)

15 files changed, 132 insertions, 30 deletions

diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 34e22cecfb..e8fc5da50e 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,8 +13,10 @@ import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl hiding (ChangeFlag)
 import Data.Bits
+import Data.Maybe (fromJust)
 import qualified Data.List as List
 import Data.Word
+import qualified Data.Map as M
 import Outputable
 import UniqFM
 
@@ -37,7 +39,7 @@ my_trace = if False then pprTrace else \_ _ a -> a
 
 -- TODO: Use optimization fuel
 elimCommonBlocks :: CmmGraph -> CmmGraph
-elimCommonBlocks g = replaceLabels env g
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
      env = iterate hashed_blocks mapEmpty
      hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
@@ -89,7 +91,7 @@ hash_block block =
         hash_lst m h = hash_node m + h `shiftL` 1
 
         hash_node :: CmmNode O x -> Word32
-        hash_node (CmmComment _) = 0 -- don't care
+        hash_node n | dont_care n = 0 -- don't care
         hash_node (CmmAssign r e) = hash_reg r + hash_e e
         hash_node (CmmStore e e') = hash_e e + hash_e e'
         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
@@ -98,6 +100,7 @@ hash_block block =
         hash_node (CmmCall e _ _ _ _ _) = hash_e e
         hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
         hash_node (CmmSwitch e _) = hash_e e
+        hash_node _ = error "hash_node: unknown Cmm node!"
 
         hash_reg :: CmmReg -> Word32
         hash_reg   (CmmLocal _) = 117
@@ -127,6 +130,13 @@ hash_block block =
         hash_list f = foldl (\z x -> f x + z) (0::Word32)
 
         cvt = fromInteger . toInteger
+
+-- | Ignore these node types for equality
+dont_care :: CmmNode O x -> Bool
+dont_care CmmComment {}  = True
+dont_care CmmTick {}     = True
+dont_care _other         = False
+
 -- Utilities: equality and substitution on the graph.
 
 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
@@ -143,7 +153,6 @@ lookupBid subst bid = case mapLookup bid subst of
 --
 eqMiddleWith :: (BlockId -> BlockId -> Bool)
              -> CmmNode O O -> CmmNode O O -> Bool
-eqMiddleWith _ (CmmComment _) (CmmComment _) = True
 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
   = r1 == r2 && eqExprWith eqBid e1 e2
 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
@@ -178,10 +187,12 @@ eqExprWith eqBid = eq
 -- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 eqBlockBodyWith eqBid block block'
-  = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
+  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
     eqLastWith eqBid l l'
   where (_,m,l)   = blockSplit block
+        nodes     = filter (not . dont_care) (blockToList m)
         (_,m',l') = blockSplit block'
+        nodes'    = filter (not . dont_care) (blockToList m')
 
 
 
@@ -202,3 +213,19 @@ eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
 eqMaybeWith _ Nothing Nothing = True
 eqMaybeWith _ _ _ = False
+
+-- | Given a block map, ensure that all "target" blocks are covered by
+-- the same ticks as the respective "source" blocks. This not only
+-- means copying ticks, but also adjusting tick scopes where
+-- necessary.
+copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+copyTicks env g
+  | mapNull env = g
+  | otherwise   = ofBlockMap (g_entry g) $ mapMap f blockMap
+  where 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
+          Nothing -> block
+          Just ls -> let findTicks l = blockTicks $ fromJust $ mapLookup l blockMap
+                     in annotateBlock (concatMap findTicks ls) block
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index d329243ad7..4ab726ea87 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -140,6 +140,7 @@ notNodeReg _                             = True
 lintCmmMiddle :: CmmNode O O -> CmmLint ()
 lintCmmMiddle node = case node of
   CmmComment _ -> return ()
+  CmmTick _    -> return ()
 
   CmmAssign reg expr -> do
             dflags <- getDynFlags
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 7eb2b61d9a..50268ee8be 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -10,7 +10,7 @@
 -- CmmNode type for representation using Hoopl graphs.
 
 module CmmNode (
-     CmmNode(..), CmmFormal, CmmActual,
+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
      UpdFrameOffset, Convention(..),
      ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
      CmmReturnInfo(..),
@@ -24,6 +24,7 @@ import DynFlags
 import FastString
 import ForeignCall
 import SMRep
+import CoreSyn (Tickish)
 
 import Compiler.Hoopl
 import Data.Maybe
@@ -41,6 +42,10 @@ data CmmNode e x where
 
   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@).
+  CmmTick :: !CmmTickish -> CmmNode O O
+
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
     -- Assign to register
 
@@ -437,6 +442,7 @@ wrapRecExp f e                    = f e
 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 mapExp _ f@(CmmEntry _)                          = f
 mapExp _ m@(CmmComment _)                        = m
+mapExp _ m@(CmmTick _)                           = m
 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
 mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
 mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
@@ -466,6 +472,7 @@ wrapRecExpM f e                    = f e
 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
 mapExpM _ (CmmEntry _)              = Nothing
 mapExpM _ (CmmComment _)            = Nothing
+mapExpM _ (CmmTick _)               = Nothing
 mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
 mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
 mapExpM _ (CmmBranch _)             = Nothing
@@ -517,6 +524,7 @@ wrapRecExpf f e                  z = f e z
 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 foldExp _ (CmmEntry {}) z                         = z
 foldExp _ (CmmComment {}) z                       = z
+foldExp _ (CmmTick {}) z                          = z
 foldExp f (CmmAssign _ e) z                       = f e z
 foldExp f (CmmStore addr e) z                     = f addr $ f e z
 foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
@@ -537,3 +545,7 @@ mapSuccessors f (CmmCondBranch p y n)  = CmmCondBranch p (f y) (f n)
 mapSuccessors f (CmmSwitch e arms)     = CmmSwitch e (map (fmap f) arms)
 mapSuccessors _ n = n
 
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
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)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 1f6d1ac0e3..043ccf0ff5 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -55,7 +55,10 @@ module CmmUtils(
 
         analFwd, analBwd, analRewFwd, analRewBwd,
         dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
-        dataflowAnalFwdBlocks
+        dataflowAnalFwdBlocks,
+
+        -- * Ticks
+        blockTicks, annotateBlock
   ) where
 
 #include "HsVersions.h"
@@ -567,3 +570,18 @@ dataflowPassBwd :: NonLocal n =>
 dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
   (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
   return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
+
+-------------------------------------------------
+-- Tick utilities
+
+-- | Extract all tick annotations from the given block
+blockTicks :: Block CmmNode C C -> [CmmTickish]
+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/PprC.hs b/compiler/cmm/PprC.hs
index 23d23ff9bb..d808341304 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -178,6 +178,8 @@ pprStmt stmt =
                           -- some debugging option is on.  They can get quite
                           -- large.
 
+    CmmTick _ -> empty
+
     CmmAssign dest src -> pprAssign dflags dest src
 
     CmmStore  dest src
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index cc3124028a..f350a8a5f9 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -43,11 +43,13 @@ import BlockId ()
 import CLabel
 import Cmm
 import CmmUtils
+import DynFlags
 import FastString
 import Outputable
 import PprCmmDecl
 import PprCmmExpr
 import Util
+import PprCore ()
 
 import BasicTypes
 import Compiler.Hoopl
@@ -179,13 +181,18 @@ pprNode :: CmmNode e x -> SDoc
 pprNode node = pp_node <+> pp_debug
   where
     pp_node :: SDoc
-    pp_node = case node of
+    pp_node = sdocWithDynFlags $ \dflags -> case node of
       -- label:
       CmmEntry id -> ppr id <> colon
 
       -- // text
       CmmComment s -> text "//" <+> ftext s
 
+      -- //tick bla<...>
+      CmmTick t -> if gopt Opt_PprShowTicks dflags
+                   then ptext (sLit "//tick") <+> ppr t
+                   else empty
+
       -- reg = expr;
       CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 
@@ -268,6 +275,7 @@ pprNode node = pp_node <+> pp_debug
       else case node of
              CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
              CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
+             CmmTick {}              -> empty
              CmmAssign {}            -> text "  // CmmAssign"
              CmmStore {}             -> text "  // CmmStore"
              CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
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))
 
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 0e9d9a2b52..5a399da164 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -494,7 +494,6 @@ data Tickish id =
 
   deriving (Eq, Ord, Data, Typeable)
 
-
 -- | A "counting tick" (where tickishCounts is True) is one that
 -- counts evaluations in some way.  We cannot discard a counting tick,
 -- and the compiler should preserve the number of counting ticks as
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 6703801ed6..42498fcefb 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -102,6 +102,7 @@ stmtToInstrs :: CmmNode e x -> LlvmM StmtData
 stmtToInstrs stmt = case stmt of
 
     CmmComment _         -> return (nilOL, []) -- nuke comments
+    CmmTick    _         -> return (nilOL, [])
 
     CmmAssign reg src    -> genAssign reg src
     CmmStore addr src    -> genStore addr src
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index c1c4a744c3..30f04e243e 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -125,6 +125,7 @@ stmtToInstrs stmt = do
   dflags <- getDynFlags
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty -> assignReg_FltCode size reg src
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 864f87f1c6..836ba70f90 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -125,6 +125,7 @@ stmtToInstrs stmt = do
   dflags <- getDynFlags
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty  -> assignReg_FltCode size reg src
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index a4115a0b6d..9e705c87f9 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -144,6 +144,7 @@ stmtToInstrs stmt = do
   is32Bit <- is32BitPlatform
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty         -> assignReg_FltCode size reg src