Add ticks on floats and ev bindswip/source-note-graveyard

5 files changed, 60 insertions, 10 deletions

diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs
index 1a88c97d55..d04e523dd1 100644
--- a/compiler/GHC/Core/Opt/FloatOut.hs
+++ b/compiler/GHC/Core/Opt/FloatOut.hs
@@ -8,7 +8,7 @@
 
 
 
-module GHC.Core.Opt.FloatOut ( floatOutwards ) where
+module GHC.Core.Opt.FloatOut ( floatOutwards, wrapTick ) where
 
 import GHC.Prelude
 
@@ -417,7 +417,7 @@ floatExpr lam@(Lam (TB _ lam_spec) _)
 floatExpr (Tick tickish expr)
   | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
   = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
-    (fs, floating_defns, Tick tickish expr') }
+    (fs, wrapTick tickish floating_defns, Tick tickish expr') }
 
   | not (tickishCounts tickish) || tickishCanSplit tickish
   = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index f77411e0b1..4cd15b6ffa 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1310,8 +1310,15 @@ simplTick env tickish expr cont
   -- application context, allowing the normal case and application
   -- optimisations to fire.
   | tickish `tickishScopesLike` SoftScope
-  = do { (floats, expr') <- simplExprF env expr cont
-       ; return (floats, mkTick tickish expr')
+  = do { -- pprTraceM "simpl_tick1" (ppr tickish)
+       ; (floats, expr') <- simplExprF env expr cont
+       --; pprTraceM "simpl_tick" (ppr floats $$ ppr tickish $$ ppr floats $$ ppr expr $$ ppr cont $$ ppr expr')
+       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),
+                                   mkTick (mkNoCount tickish) rhs)
+              -- when wrapping a float with mkTick, we better zap the Id's
+              -- strictness info and arity, because it might be wrong now.
+       ; let floats' = mapFloats wrap_float floats
+       ; return (floats', mkTick tickish expr')
        }
 
   -- Push tick inside if the context looks like this will allow us to
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 54a5f171ec..8be549602b 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -32,7 +32,7 @@ module GHC.Core.Opt.Simplify.Env (
         SimplFloats(..), emptyFloats, mkRecFloats,
         mkFloatBind, addLetFloats, addJoinFloats, addFloats,
         extendFloats, wrapFloats,
-        doFloatFromRhs, getTopFloatBinds,
+        doFloatFromRhs, getTopFloatBinds, mapFloats,
 
         -- * LetFloats
         LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
@@ -126,6 +126,9 @@ data SimplFloats
       , sfInScope :: InScopeSet  -- All OutVars
       }
 
+mapFloats :: ((Id, CoreExpr) -> (Id, CoreExpr)) -> SimplFloats -> SimplFloats
+mapFloats f sf = sf { sfLetFloats = mapLetFloats (sfLetFloats sf) f }
+
 instance Outputable SimplFloats where
   ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
     = text "SimplFloats"
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index a8935e9cd9..2710ec3b19 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -170,7 +170,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
 
         ; core_wrap <- dsHsWrapper co_fn
         ; let body' = mkOptTickBox tick body
-              rhs   = core_wrap (mkLams args body')
+              rhs   = mkOptTickBox tick (core_wrap (mkLams args body'))
               core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
               force_var
                   -- Bindings are strict when -XStrict is enabled
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 8050332a0f..2004db959f 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -69,6 +69,9 @@ import Trace.Hpc.Util
 import qualified Data.ByteString as BS
 import Data.Set (Set)
 import qualified Data.Set as Set
+import GHC.Utils.Trace
+import GHC.Tc.Types.Evidence
+import GHC.Core
 
 {-
 ************************************************************************
@@ -286,11 +289,14 @@ addTickLHsBinds = mapBagM addTickLHsBind
 
 addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
 addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
+                                       abs_ev_binds = evbinds,
                                        abs_exports = abs_exports })) =
   withEnv add_exports $
     withEnv add_inlines $ do
       binds' <- addTickLHsBinds binds
-      return $ L pos $ bind { abs_binds = binds' }
+      ev <- mapM (addTickEvBinds (locA pos)) evbinds
+      pprTraceM "len_binds" (ppr (length evbinds) $$ ppr abs_exports)
+      return $ L pos $ bind { abs_binds = binds', abs_ev_binds = ev }
   where
    -- in AbsBinds, the Id on each binding is not the actual top-level
    -- Id that we are defining, they are related by the abs_exports
@@ -310,7 +316,7 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                       , isInlinePragma (idInlinePragma pid) ] }
 
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L loc id, fun_ext = wrapper }))) = do
   let name = getOccString id
   decl_path <- getPathEntry
   density <- getDensity
@@ -329,6 +335,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
         addPathEntry name $
         addTickMatchGroup False (fun_matches funBind)
 
+  wrapper' <- addPathEntry name $ addTickHsWrapper (locA loc) wrapper
+
   blackListed <- isBlackListed (locA pos)
   exported_names <- liftM exports getEnv
 
@@ -348,7 +356,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
 
   let mbCons = maybe Prelude.id (:)
   return $ L pos $ funBind { fun_matches = mg
-                           , fun_tick = tick `mbCons` fun_tick funBind }
+                           , fun_tick = tick `mbCons` fun_tick funBind
+                           , fun_ext = wrapper' }
 
    where
    -- a binding is a simple pattern binding if it is a funbind with
@@ -400,6 +409,36 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
 
+addTickHsWrapper :: SrcSpan -> HsWrapper -> TM HsWrapper
+addTickHsWrapper pos (WpCompose w1 w2)= WpCompose <$> addTickHsWrapper pos w1 <*> addTickHsWrapper pos w2
+addTickHsWrapper pos (WpLet ev_binds) = WpLet <$> addTickEvBinds pos ev_binds
+addTickHsWrapper _ wrap = return wrap
+
+
+addTickEvBinds :: SrcSpan -> TcEvBinds -> TM TcEvBinds
+addTickEvBinds (RealSrcSpan pos _) (EvBinds ev_b) = do
+  pprTraceM "addTickEvBinds" (ppr pos $$ ppr ev_b)
+  EvBinds <$> mapM (addTickEvBind pos) ev_b
+addTickEvBinds pos u = do
+  pprTraceM "FAIL-addTickEvBinds" (ppr pos <+> ppr u)
+  return u
+
+addTickEvBind :: RealSrcSpan -> EvBind -> TM EvBind
+addTickEvBind pos eb = do
+  pprTraceM "addTickEvBind" (ppr pos)
+  rhs' <- addPathEntry (occNameString (getOccName (eb_lhs eb))) $  addTickEvTerm pos (eb_rhs eb)
+  return $ eb { eb_rhs = rhs' }
+
+addTickEvTerm :: RealSrcSpan -> EvTerm -> TM EvTerm
+addTickEvTerm pos (EvExpr e) = do
+  pprTraceM "addTickEvBindEv" (ppr pos)
+  decl_path <- getPathEntry
+  return $ EvExpr (Tick (SourceNote pos (concat (intersperse "." decl_path))) e)
+addTickEvTerm _ e = return e
+
+
+
+
 bindTick
   :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
 bindTick density name pos fvs = do
@@ -647,7 +686,8 @@ addTickHsExpr (HsProc x pat cmdtop) =
         liftM2 (HsProc x)
                 (addTickLPat pat)
                 (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
+addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = do
+        pprTraceM "wrap_expr" (ppr w)
         liftM (XExpr . WrapExpr . HsWrap w) $
               (addTickHsExpr e)        -- Explicitly no tick on inside
 addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =