Source notes (CorePrep and Stg support)

This is basically just about continuing maintaining source notes after
the Core stage. Unfortunately, this is more involved as it might seem,
as there are more restrictions on where ticks are allowed to show up.

Notes:

* We replace the StgTick / StgSCC constructors with a unified StgTick
  that can carry any tickish.

* For handling constructor or lambda applications, we generally float
  ticks out.

* Note that thanks to the NonLam placement, we know that source notes
  can never appear on lambdas. This means that as long as we are
  careful to always use mkTick, we will never violate CorePrep
  invariants.

* This is however not automatically true for eta expansion, which
  needs to somewhat awkwardly strip, then re-tick the expression in
  question.

* Where CorePrep floats out lets, we make sure to wrap them in the
  same spirit as FloatOut.

* Detecting selector thunks becomes a bit more involved, as we can run
  into ticks at multiple points.

(From Phabricator D169)

9 files changed, 226 insertions, 167 deletions

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 444112f967..3c17160750 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -31,7 +31,7 @@ import StgCmmClosure
 import StgCmmForeign    (emitPrimCall)
 
 import MkGraph
-import CoreSyn          ( AltCon(..) )
+import CoreSyn          ( AltCon(..), tickishIsCode )
 import SMRep
 import Cmm
 import CmmInfo
@@ -50,7 +50,6 @@ import Outputable
 import FastString
 import DynFlags
 
-import Data.Maybe
 import Control.Monad
 
 #if __GLASGOW_HASKELL__ >= 709
@@ -268,14 +267,22 @@ mkRhsClosure    dflags bndr _cc _bi
                 [NonVoid the_fv]                -- Just one free var
                 upd_flag                -- Updatable thunk
                 []                      -- A thunk
-                (StgCase (StgApp scrutinee [{-no args-}])
-                      _ _ _ _   -- ignore uniq, etc.
-                      (AlgAlt _)
-                      [(DataAlt _, params, _use_mask,
-                            (StgApp selectee [{-no args-}]))])
-  |  the_fv == scrutinee                -- Scrutinee is the only free variable
-  && isJust maybe_offset                -- Selectee is a component of the tuple
-  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
+                expr
+  | let strip = snd . stripStgTicksTop (not . tickishIsCode)
+  , StgCase (StgApp scrutinee [{-no args-}])
+         _ _ _ _   -- ignore uniq, etc.
+         (AlgAlt _)
+         [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
+  , StgApp selectee [{-no args-}] <- strip sel_expr
+  , the_fv == scrutinee                -- Scrutinee is the only free variable
+
+  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
+                                   -- Just want the layout
+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
+
+  , let offset_into_int = bytesToWordsRoundUp dflags the_offset
+                          - fixedHdrSizeW dflags
+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
   = -- NOT TRUE: ASSERT(is_single_constructor)
     -- The simplifier may have statically determined that the single alternative
     -- is the only possible case and eliminated the others, even if there are
@@ -284,16 +291,8 @@ mkRhsClosure    dflags bndr _cc _bi
     -- will evaluate to.
     --
     -- srt is discarded; it must be empty
-    cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
-  where
-    lf_info               = mkSelectorLFInfo bndr offset_into_int
-                                 (isUpdatable upd_flag)
-    (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
-                               -- Just want the layout
-    maybe_offset          = assocMaybe params_w_offsets (NonVoid selectee)
-    Just the_offset       = maybe_offset
-    offset_into_int       = bytesToWordsRoundUp dflags the_offset
-                             - fixedHdrSizeW dflags
+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
 
 ---------- Note [Ap thunks] ------------------
 mkRhsClosure    dflags bndr _cc _bi
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index b2b64f8650..9097e7fa12 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -66,10 +66,7 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
 
 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
 cgExpr (StgConApp con args)  = cgConApp con args
-cgExpr (StgSCC cc tick push expr) = do { emitSetCCC cc tick push; cgExpr expr }
-cgExpr (StgTick m n expr) = do dflags <- getDynFlags
-                               emit (mkTickBox dflags m n)
-                               cgExpr expr
+cgExpr (StgTick t e)         = cgTick t >> cgExpr e
 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
 
@@ -852,3 +849,19 @@ emitEnter fun = do
        ; return (ReturnedTo lret off)
        }
   }
+
+------------------------------------------------------------------------
+--              Ticks
+------------------------------------------------------------------------
+
+-- | Generate Cmm code for a tick. Depending on the type of Tickish,
+-- this will either generate actual Cmm instrumentation code, or
+-- simply pass on the annotation as a @CmmTickish@.
+cgTick :: Tickish Id -> FCode ()
+cgTick tick
+  = do { dflags <- getDynFlags
+       ; case tick of
+           ProfNote   cc t p -> emitSetCCC cc t p
+           HpcTick    m n    -> emit (mkTickBox dflags m n)
+           _other            -> return () -- ignore
+       }
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index f1bdd73a59..1ca54fe6aa 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -116,6 +116,10 @@ The goal of this pass is to prepare for code generation.
     special case where we use the S# constructor for Integers that
     are in the range of Int.
 
+11. Uphold tick consistency while doing this: We move ticks out of
+    (non-type) applications where we can, and make sure that we
+    annotate according to scoping rules when floating.
+
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
@@ -404,7 +408,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
        ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
 
        -- Make the arity match up
-       ; (floats3, rhs')
+       ; (floats3, rhs3)
             <- if manifestArity rhs1 <= arity
                then return (floats2, cpeEtaExpand arity rhs2)
                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
@@ -414,15 +418,18 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
                         ; return ( addFloat floats2 float
                                  , cpeEtaExpand arity (Var v)) })
 
+        -- Wrap floating ticks
+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3
+
         -- Record if the binder is evaluated
         -- and otherwise trim off the unfolding altogether
         -- It's not used by the code generator; getting rid of it reduces
         -- heap usage and, since we may be changing uniques, we'd have
         -- to substitute to keep it right
-       ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
+       ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding
                    | otherwise      = bndr `setIdUnfolding` noUnfolding
 
-       ; return (floats3, bndr', rhs') }
+       ; return (floats4, bndr', rhs4) }
   where
     is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted
 
@@ -512,11 +519,13 @@ cpeRhsE env (Let bind expr)
        ; return (new_binds `appendFloats` floats, body) }
 
 cpeRhsE env (Tick tickish expr)
-  | ignoreTickish tickish
-  = cpeRhsE env expr
-  | otherwise         -- Just SCCs actually
+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
+  = do { (floats, body) <- cpeRhsE env expr
+         -- See [Floating Ticks in CorePrep]
+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
+  | otherwise
   = do { body <- cpeBodyNF env expr
-       ; return (emptyFloats, Tick tickish' body) }
+       ; return (emptyFloats, mkTick tickish' body) }
   where
     tickish' | Breakpoint n fvs <- tickish
              = Breakpoint n (map (lookupCorePrepEnv env) fvs)
@@ -596,7 +605,7 @@ rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 rhsToBody (Tick t expr)
   | tickishScoped t == NoScope  -- only float out of non-scoped annotations
   = do { (floats, expr') <- rhsToBody expr
-       ; return (floats, Tick t expr') }
+       ; return (floats, mkTick t expr') }
 
 rhsToBody (Cast e co)
         -- You can get things like
@@ -696,8 +705,11 @@ cpeApp env expr
            ; return (Cast fun' co, hd, ty2, floats, ss) }
 
     collect_args (Tick tickish fun) depth
-      | ignoreTickish tickish   -- Drop these notes altogether
-      = collect_args fun depth  -- They aren't used by the code generator
+      | tickishPlace tickish == PlaceNonLam
+        && tickish `tickishScopesLike` SoftScope
+      = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+             -- See [Floating Ticks in CorePrep]
+           ; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) }
 
         -- N-variable fun, better let-bind it
     collect_args fun depth
@@ -818,10 +830,6 @@ of the scope of a `seq`, or dropped the `seq` altogether.
 ************************************************************************
 -}
 
--- we don't ignore any Tickishes at the moment.
-ignoreTickish :: Tickish Id -> Bool
-ignoreTickish _ = False
-
 cpe_ExprIsTrivial :: CoreExpr -> Bool
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)        = True
@@ -925,6 +933,9 @@ tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
   where
     fvs = exprFreeVars r
 
+tryEtaReducePrep bndrs (Tick tickish e)
+  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
+
 tryEtaReducePrep _ _ = Nothing
 
 {-
@@ -948,11 +959,15 @@ data FloatingBind
       Id CpeBody
       Bool              -- The bool indicates "ok-for-speculation"
 
+ -- | See Note [Floating Ticks in CorePrep]
+ | FloatTick (Tickish Id)
+
 data Floats = Floats OkToSpec (OrdList FloatingBind)
 
 instance Outputable FloatingBind where
   ppr (FloatLet b) = ppr b
   ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
+  ppr (FloatTick t) = ppr t
 
 instance Outputable Floats where
   ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
@@ -998,6 +1013,7 @@ wrapBinds (Floats _ binds) body
   where
     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
     mk_bind (FloatLet bind)        body = Let bind body
+    mk_bind (FloatTick tickish)    body = mkTick tickish body
 
 addFloat :: Floats -> FloatingBind -> Floats
 addFloat (Floats ok_to_spec floats) new_float
@@ -1007,6 +1023,7 @@ addFloat (Floats ok_to_spec floats) new_float
     check (FloatCase _ _ ok_for_spec)
         | ok_for_spec  =  IfUnboxedOk
         | otherwise    =  NotOkToSpec
+    check FloatTick{}  = OkToSpec
         -- The ok-for-speculation flag says that it's safe to
         -- float this Case out of a let, and thereby do it more eagerly
         -- We need the top-level flag because it's never ok to float
@@ -1075,6 +1092,9 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
         rs' = map (subst_expr subst') rs
         new_fb = FloatLet (Rec (bs' `zip` rs'))
 
+    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
+      = go (subst, fbs_out `snocOL` ft) fbs_in
+
     go _ _ = Nothing      -- Encountered a caffy binding
 
     ------------
@@ -1222,3 +1242,50 @@ newVar ty
  = seqType ty `seq` do
      uniq <- getUniqueM
      return (mkSysLocal (fsLit "sat") uniq ty)
+
+
+------------------------------------------------------------------------------
+-- Floating ticks
+-- ---------------------------------------------------------------------------
+--
+-- Note [Floating Ticks in CorePrep]
+--
+-- It might seem counter-intuitive to float ticks by default, given
+-- that we don't actually want to move them if we can help it. On the
+-- other hand, nothing gets very far in CorePrep anyway, and we want
+-- to preserve the order of let bindings and tick annotations in
+-- relation to each other. For example, if we just wrapped let floats
+-- when they pass through ticks, we might end up performing the
+-- following transformation:
+--
+--   src<...> let foo = bar in baz
+--   ==>  let foo = src<...> bar in src<...> baz
+--
+-- Because the let-binding would float through the tick, and then
+-- immediately materialize, achieving nothing but decreasing tick
+-- accuracy. The only special case is the following scenario:
+--
+--   let foo = src<...> (let a = b in bar) in baz
+--   ==>  let foo = src<...> bar; a = src<...> b in baz
+--
+-- Here we would not want the source tick to end up covering "baz" and
+-- therefore refrain from pushing ticks outside. Instead, we copy them
+-- into the floating binds (here "a") in cpePair. Note that where "b"
+-- or "bar" are (value) lambdas we have to push the annotations
+-- further inside in order to uphold our rules.
+--
+-- All of this is implemented below in @wrapTicks@.
+
+-- | Like wrapFloats, but only wraps tick floats
+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
+wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
+  where (floats1, expr') = foldrOL go (nilOL, expr) floats0
+        go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
+                                   (mapOL (wrap t) fs, mkTick t e)
+        go other         (fs, e) = (other `consOL` fs, e)
+        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)
+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"
+                                             (ppr other)
+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs
index 9ad5b5fc3d..dfa3d052a4 100644
--- a/compiler/profiling/SCCfinal.hs
+++ b/compiler/profiling/SCCfinal.hs
@@ -31,6 +31,7 @@ import UniqSupply       ( UniqSupply )
 import ListSetOps       ( removeDups )
 import Outputable
 import DynFlags
+import CoreSyn          ( Tickish(..) )
 import FastString
 import SrcLoc
 import Util
@@ -93,7 +94,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds
     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
     do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
-                     (StgSCC _cc False{-not tick-} _push (StgConApp con args)))
+                     (StgTick (ProfNote _cc False{-not tick-} _push)
+                              (StgConApp con args)))
       | not (isDllConApp dflags mod_name con args)
         -- Trivial _scc_ around nothing but static data
         -- Eliminate _scc_ ... and turn into StgRhsCon
@@ -146,10 +148,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
     do_expr (StgOpApp con args res_ty)
       = return (StgOpApp con args res_ty)
 
-    do_expr (StgSCC cc tick push expr) = do -- Ha, we found a cost centre!
+    do_expr (StgTick note@(ProfNote cc _ _) expr) = do
+        -- Ha, we found a cost centre!
         collectCC cc
         expr' <- do_expr expr
-        return (StgSCC cc tick push expr')
+        return (StgTick note expr')
+
+    do_expr (StgTick ti expr) = do
+        expr' <- do_expr expr
+        return (StgTick ti expr')
 
     do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
         expr' <- do_expr expr
@@ -168,10 +175,6 @@ stgMassageForProfiling dflags mod_name _us stg_binds
           (b,e) <- do_let b e
           return (StgLetNoEscape lvs1 lvs2 b e)
 
-    do_expr (StgTick m n expr) = do
-          expr' <- do_expr expr
-          return (StgTick m n expr')
-
     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
 
     ----------------------------------
@@ -201,7 +204,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds
         -- We should really attach (PushCC cc CurrentCCS) to the rhs,
         -- but need to reinstate PushCC for that.
     do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt []
-               (StgSCC cc False{-not tick-} _push (StgConApp con args)))
+               (StgTick (ProfNote cc False{-not tick-} _push)
+                        (StgConApp con args)))
       = do collectCC cc
            return (StgRhsCon currentCCS con args)
 
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 4823baea3d..dd1f5a64d2 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -151,8 +151,7 @@ statExpr (StgApp _ _)     = countOne Applications
 statExpr (StgLit _)       = countOne Literals
 statExpr (StgConApp _ _)  = countOne ConstructorApps
 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
-statExpr (StgSCC _ _ _ e) = statExpr e
-statExpr (StgTick _ _ e)  = statExpr e
+statExpr (StgTick _ e)    = statExpr e
 
 statExpr (StgLetNoEscape _ _ binds body)
   = statBinding False{-not top-level-} binds    `combineSE`
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 303bfa74ee..87ce0ed93f 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -130,10 +130,8 @@ unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
   where
     (us1, us2) = splitUniqSupply us
 
-unariseExpr us rho (StgSCC cc bump_entry push_cc e)
-  = StgSCC cc bump_entry push_cc (unariseExpr us rho e)
-unariseExpr us rho (StgTick mod tick_n e)
-  = StgTick mod tick_n (unariseExpr us rho e)
+unariseExpr us rho (StgTick tick e)
+  = StgTick tick (unariseExpr us rho e)
 
 ------------------------
 unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> RepType -> [StgAlt] -> (AltType, [StgAlt])
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 55a31d4255..20bbf3b729 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -317,28 +317,9 @@ mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
             -> SRT -> Id -> StgBinderInfo -> StgExpr
             -> StgRhs
 
-mkTopStgRhs _ _ rhs_fvs srt _ binder_info (StgLam bndrs body)
-  = StgRhsClosure noCCS binder_info
-                  (getFVs rhs_fvs)
-                  ReEntrant
-                  srt
-                  bndrs body
-
-mkTopStgRhs dflags this_mod _ _ _ _ (StgConApp con args)
-  | not (isDllConApp dflags this_mod con args)  -- Dynamic StgConApps are updatable
-  = StgRhsCon noCCS con args
-
-mkTopStgRhs _ _ rhs_fvs srt bndr binder_info rhs
-  = StgRhsClosure noCCS binder_info
-                  (getFVs rhs_fvs)
-                  (getUpdateFlag bndr)
-                  srt
-                  [] rhs
-
-getUpdateFlag :: Id -> UpdateFlag
-getUpdateFlag bndr
-  = if isSingleUsed (idDemandInfo bndr)
-    then SingleEntry else Updatable
+mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
+        -- Dynamic StgConApps are updatable
+  where con_updateable con args = isDllConApp dflags this_mod con args
 
 -- ---------------------------------------------------------------------------
 -- Expressions
@@ -364,13 +345,13 @@ coreToStgExpr
 -- should have converted them all to a real core representation.
 coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
 coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
-coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
-coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
+coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
 
 coreToStgExpr expr@(App _ _)
-  = coreToStgApp Nothing f args
+  = coreToStgApp Nothing f args ticks
   where
-    (f, args) = myCollectArgs expr
+    (f, args, ticks) = myCollectArgs expr
 
 coreToStgExpr expr@(Lam _ _)
   = let
@@ -387,19 +368,14 @@ coreToStgExpr expr@(Lam _ _)
 
     return (result_expr, fvs, escs)
 
-coreToStgExpr (Tick (HpcTick m n) expr)
-  = do (expr2, fvs, escs) <- coreToStgExpr expr
-       return (StgTick m n expr2, fvs, escs)
-
-coreToStgExpr (Tick (ProfNote cc tick push) expr)
-  = do (expr2, fvs, escs) <- coreToStgExpr expr
-       return (StgSCC cc tick push expr2, fvs, escs)
-
-coreToStgExpr (Tick Breakpoint{} _expr)
-  = panic "coreToStgExpr: breakpoint should not happen"
-
-coreToStgExpr (Tick _ expr)
-  = {- dropped for now ... -} coreToStgExpr expr
+coreToStgExpr (Tick tick expr)
+  = do case tick of
+         HpcTick{}    -> return ()
+         ProfNote{}   -> return ()
+         SourceNote{} -> return ()
+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+       (expr2, fvs, escs) <- coreToStgExpr expr
+       return (StgTick tick expr2, fvs, escs)
 
 coreToStgExpr (Cast expr _)
   = coreToStgExpr expr
@@ -544,11 +520,12 @@ coreToStgApp
                                         -- with specified update flag
         -> Id                           -- Function
         -> [CoreArg]                    -- Arguments
+        -> [Tickish Id]                 -- Debug ticks
         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 
 
-coreToStgApp _ f args = do
-    (args', args_fvs) <- coreToStgArgs args
+coreToStgApp _ f args ticks = do
+    (args', args_fvs, ticks') <- coreToStgArgs args
     how_bound <- lookupVarLne f
 
     let
@@ -617,10 +594,12 @@ coreToStgApp _ f args = do
                                 -- All the free vars of the args are disqualified
                                 -- from being let-no-escaped.
 
+        tapp = foldr StgTick app (ticks ++ ticks')
+
     -- Forcing these fixes a leak in the code generator, noticed while
     -- profiling for trac #4367
     app `seq` fvs `seq` seqVarSet vars `seq` return (
-        app,
+        tapp,
         fvs,
         vars
      )
@@ -632,24 +611,31 @@ coreToStgApp _ f args = do
 -- This is the guy that turns applications into A-normal form
 -- ---------------------------------------------------------------------------
 
-coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo, [Tickish Id])
 coreToStgArgs []
-  = return ([], emptyFVInfo)
+  = return ([], emptyFVInfo, [])
 
 coreToStgArgs (Type _ : args) = do     -- Type argument
-    (args', fvs) <- coreToStgArgs args
-    return (args', fvs)
+    (args', fvs, ts) <- coreToStgArgs args
+    return (args', fvs, ts)
 
 coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
-  = do { (args', fvs) <- coreToStgArgs args
-       ; return (StgVarArg coercionTokenId : args', fvs) }
+  = do { (args', fvs, ts) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', fvs, ts) }
+
+coreToStgArgs (Tick t e : args)
+  = ASSERT( not (tickishIsCode t) )
+    do { (args', fvs, ts) <- coreToStgArgs (e : args)
+       ; return (args', fvs, t:ts) }
 
 coreToStgArgs (arg : args) = do         -- Non-type argument
-    (stg_args, args_fvs) <- coreToStgArgs args
+    (stg_args, args_fvs, ticks) <- coreToStgArgs args
     (arg', arg_fvs, _escs) <- coreToStgExpr arg
     let
         fvs = args_fvs `unionFVInfo` arg_fvs
-        stg_arg = case arg' of
+
+        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
+        stg_arg = case arg'' of
                        StgApp v []      -> StgVarArg v
                        StgConApp con [] -> StgVarArg (dataConWorkId con)
                        StgLit lit       -> StgLitArg lit
@@ -677,7 +663,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         -- We also want to check if a pointer is cast to a non-ptr etc
 
     WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
-     return (stg_arg : stg_args, fvs)
+     return (stg_arg : stg_args, fvs, ticks ++ aticks)
 
 
 -- ---------------------------------------------------------------------------
@@ -824,21 +810,31 @@ coreToStgRhs scope_fv_info binders (bndr, rhs) = do
     bndr_info = lookupFVInfo scope_fv_info bndr
 
 mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs = mkStgRhs' con_updateable
+  where con_updateable _ _ = False
 
-mkStgRhs _ _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
-
-mkStgRhs rhs_fvs srt _ binder_info (StgLam bndrs body)
+mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
+            -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
+  | StgLam bndrs body <- rhs
   = StgRhsClosure noCCS binder_info
-                  (getFVs rhs_fvs)
-                  ReEntrant
-                  srt bndrs body
-
-mkStgRhs rhs_fvs srt bndr binder_info rhs
+                   (getFVs rhs_fvs)
+                   ReEntrant
+                   srt bndrs body
+  | StgConApp con args <- unticked_rhs
+  , not (con_updateable con args)
+  = StgRhsCon noCCS con args
+  | otherwise
   = StgRhsClosure noCCS binder_info
-                  (getFVs rhs_fvs)
-                  upd_flag srt [] rhs
-  where
-     upd_flag = getUpdateFlag bndr
+                   (getFVs rhs_fvs)
+                   upd_flag srt [] rhs
+ where
+
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isSingleUsed (idDemandInfo bndr)  = SingleEntry
+             | otherwise                         = Updatable
+
   {-
     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
     well; and making these into simple non-updatable thunks breaks other
@@ -1163,26 +1159,23 @@ myCollectBinders expr
   = go [] expr
   where
     go bs (Lam b e)          = go (b:bs) e
-    go bs e@(Tick t e')
-        | tickishIsCode t    = (reverse bs, e)
-        | otherwise          = go bs e'
-        -- Ignore only non-code source annotations
     go bs (Cast e _)         = go bs e
     go bs e                  = (reverse bs, e)
 
-myCollectArgs :: CoreExpr -> (Id, [CoreArg])
+myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
         -- We assume that we only have variables
         -- in the function position by now
 myCollectArgs expr
-  = go expr []
+  = go expr [] []
   where
-    go (Var v)          as = (v, as)
-    go (App f a) as        = go f (a:as)
-    go (Tick _ _)     _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
-    go (Cast e _)       as = go e as
-    go (Lam b e)        as
-       | isTyVar b         = go e as  -- Note [Collect args]
-    go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Var v)          as ts = (v, as, ts)
+    go (App f a)        as ts = go f (a:as) ts
+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
+                                go e as (t:ts) -- ticks can appear in type apps
+    go (Cast e _)       as ts = go e as ts
+    go (Lam b e)        as ts
+       | isTyVar b            = go e as ts -- Note [Collect args]
+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 
 -- Note [Collect args]
 -- ~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 5bd25e3116..b415b4f2d9 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -187,7 +187,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do
       addInScopeVars binders $
         lintStgExpr body
 
-lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr
+lintStgExpr (StgTick _ expr) = lintStgExpr expr
 
 lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
     _ <- MaybeT $ lintStgExpr scrut
@@ -210,8 +210,6 @@ lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
                   where
                      bad_bndr = mkDefltMsg bndr tc
 
-lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
-
 lintStgAlts :: [StgAlt]
             -> Type               -- Type of scrutinee
             -> LintM (Maybe Type) -- Just ty => type is accurage
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 7577e837a8..6c6d4bfb1d 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -38,6 +38,7 @@ module StgSyn (
         stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
         isDllConApp,
         stgArgType,
+        stripStgTicksTop,
 
         pprStgBinding, pprStgBindings,
         pprStgLVs
@@ -46,8 +47,8 @@ module StgSyn (
 #include "HsVersions.h"
 
 import Bitmap
-import CoreSyn     ( AltCon )
-import CostCentre  ( CostCentreStack, CostCentre )
+import CoreSyn     ( AltCon, Tickish )
+import CostCentre  ( CostCentreStack )
 import DataCon
 import DynFlags
 import FastString
@@ -55,7 +56,7 @@ import ForeignCall ( ForeignCall )
 import Id
 import IdInfo      ( mayHaveCafRefs )
 import Literal     ( Literal, literalType )
-import Module
+import Module      ( Module )
 import Outputable
 import Packages    ( isDllName )
 import Platform
@@ -143,6 +144,14 @@ stgArgType :: StgArg -> Type
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
 
+
+-- | Strip ticks of a given type from an STG expression
+stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
+stripStgTicksTop p = go []
+   where go ts (StgTick t e) | p t = go (t:ts) e
+         go ts other               = (reverse ts, other)
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -363,35 +372,18 @@ And so the code for let(rec)-things:
         (GenStgExpr bndr occ)       -- body
 
 {-
-************************************************************************
-*                                                                      *
-\subsubsection{@GenStgExpr@: @scc@ expressions}
-*                                                                      *
-************************************************************************
-
-For @scc@ expressions we introduce a new STG construct.
--}
-
-  | StgSCC
-        CostCentre             -- label of SCC expression
-        !Bool                  -- bump the entry count?
-        !Bool                  -- push the cost centre?
-        (GenStgExpr bndr occ)  -- scc expression
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{@GenStgExpr@: @hpc@ expressions}
-*                                                                      *
-************************************************************************
+%************************************************************************
+%*                                                                      *
+\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
+%*                                                                      *
+%************************************************************************
 
 Finally for @hpc@ expressions we introduce a new STG construct.
 -}
 
   | StgTick
-        Module                 -- the module of the source of this tick
-        Int                    -- tick number
-        (GenStgExpr bndr occ)  -- sub expression
+    (Tickish bndr)
+    (GenStgExpr bndr occ)       -- sub expression
 
 -- END of GenStgExpr
 
@@ -742,16 +734,12 @@ pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
                              char ']'])))
                 2 (ppr expr)]
 
-pprStgExpr (StgSCC cc tick push expr)
-  = sep [ hsep [scc, ppr cc], pprStgExpr expr ]
-  where
-    scc | tick && push = ptext (sLit "_scc_")
-        | tick         = ptext (sLit "_tick_")
-        | otherwise    = ptext (sLit "_push_")
+pprStgExpr (StgTick tickish expr)
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_PprShowTicks dflags
+    then sep [ ppr tickish, pprStgExpr expr ]
+    else pprStgExpr expr
 
-pprStgExpr (StgTick m n expr)
-  = sep [ hsep [ptext (sLit "_tick_"),  pprModule m,text (show n)],
-          pprStgExpr expr ]
 
 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
   = sep [sep [ptext (sLit "case"),