Source note changeswip/source-notes-change

9 files changed, 75 insertions, 14 deletions

diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs
index fbed53fbf3..524c4a5cd0 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
 
@@ -418,7 +418,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 1398bfd6e7..4558686eb1 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1312,8 +1312,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/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 918530695f..93e63cffe0 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -299,7 +299,7 @@ mkDataConWorkers dflags mod_loc data_tycons
    -- If we want to generate debug info, we put a source note on the
    -- worker. This is useful, especially for heap profiling.
    tick_it name
-     | debugLevel dflags == 0                = id
+     | not (needSourceNotes dflags)           = id
      | RealSrcSpan span _ <- nameSrcSpan name = tick span
      | Just file <- ml_hs_file mod_loc       = tick (span1 file)
      | otherwise                             = tick (span1 "???")
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index d1c29bc824..2b9eaa1db9 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -39,6 +39,7 @@ module GHC.Driver.Session (
         lang_set,
         DynamicTooState(..), dynamicTooState, setDynamicNow,
         sccProfilingEnabled,
+        needSourceNotes,
         DynFlags(..),
         outputFile, objectSuf, ways,
         FlagSpec(..),
@@ -4778,6 +4779,11 @@ isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of
 sccProfilingEnabled :: DynFlags -> Bool
 sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)
 
+-- | Indicate whether we need to generate source notes
+needSourceNotes :: DynFlags -> Bool
+needSourceNotes dflags = debugLevel dflags > 0
+                       || gopt Opt_InfoTableMap dflags
+
 -- -----------------------------------------------------------------------------
 -- Linker/compiler information
 
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 596e4333b1..c5b190b670 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 2e45539fba..6bc9349359 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -63,6 +63,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
 
 {-
 ************************************************************************
@@ -271,11 +274,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
@@ -295,7 +301,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
@@ -314,6 +320,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
 
@@ -333,7 +341,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
@@ -385,6 +394,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
@@ -632,7 +671,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))) =
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 782b572cf8..95f4496212 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1561,9 +1561,9 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
 tcIfaceExpr (IfaceTick tickish expr) = do
     expr' <- tcIfaceExpr expr
     -- If debug flag is not set: Ignore source notes
-    dbgLvl <- fmap debugLevel getDynFlags
+    need_notes <- needSourceNotes <$> getDynFlags
     case tickish of
-      IfaceSource{} | dbgLvl == 0
+      IfaceSource{} | not (need_notes)
                     -> return expr'
       _otherwise    -> do
         tickish' <- tcIfaceTickish tickish
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index bea6fe5c8e..5e4573967b 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -62,7 +62,12 @@ collectStgBind (StgRec pairs) = do
 
 collectStgRhs :: Id -> StgRhs -> M StgRhs
 collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
-  e' <- collectExpr e
+  let
+    name = idName bndr
+    with_span = case nameSrcSpan name of
+                  RealSrcSpan pos _ -> id -- withSpan (pos, occNameString (getOccName name))
+                  _ -> id
+  e' <- with_span $ collectExpr e
   recordInfo bndr e'
   return $ StgRhsClosure ext cc us bs e'
 collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do