Source notes (Core support)

This patch introduces "SourceNote" tickishs that carry a reference to the
original source code. They are meant to be passed along the compilation
pipeline with as little disturbance to optimization processes as possible.

Generation is triggered by command line parameter -g. It's free and
fits with the intended end result (generation of DWARF). Internally we
say that we compile with "debugging", which is probably at least
slightly confusing given the plethora of other debugging options we have.

Note that this pass creates *lots* of tick nodes. We take care to
remove duplicated and overlapping source ticks, which gets rid of most
of them. Possible optimization could be to make Tick carry a list of
Tickishs instead of one at a time.

Keeping ticks from getting into the way of Core transformations is
tricky, but doable. The changes in this patch produce identical Core
in all cases I tested (nofib). We should probably look for a way to
make a test-case out of this.

compiler/basicTypes/SrcLoc.lhs

@@ -45,7 +45,7 @@ module SrcLoc (
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        showUserSpan,
+        showUserSpan, showUserRealSpan,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -55,6 +55,7 @@ module SrcLoc (
 
         -- ** Predicates on SrcSpan
         isGoodSrcSpan, isOneLineSpan,
+        containsSpan,
 
         -- * Located
         Located,
@@ -263,8 +264,8 @@ data SrcSpan =
   | UnhelpfulSpan !FastString   -- Just a general indication
                                 -- also used to indicate an empty span
 
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
-                                -- derive Show for Token
+  deriving (Eq, Ord, Typeable, Show) -- Show is used by Lexer.x, because we
+                                     -- derive Show for Token
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
 noSrcSpan, wiredInSrcSpan :: SrcSpan
@@ -347,6 +348,16 @@ isOneLineSpan :: SrcSpan -> Bool
 isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
 isOneLineSpan (UnhelpfulSpan _) = False
 
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True if the spans are eqal.
+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
+containsSpan s1 s2
+  = srcSpanFile s1 == srcSpanFile s2
+    && (srcSpanStartLine s1, srcSpanStartCol s1)
+       <= (srcSpanStartLine s2, srcSpanStartCol s2)
+    && (srcSpanEndLine s1, srcSpanEndCol s1)
+       >= (srcSpanEndLine s2, srcSpanEndCol s2)
+
 \end{code}
 
 %************************************************************************
@@ -423,12 +434,11 @@ srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
 
 \begin{code}
 
--- We want to order SrcSpans first by the start point, then by the end point.
-instance Ord SrcSpan where
+-- We want to order RealSrcSpans first by the start point, then by the end point.
+instance Ord RealSrcSpan where
   a `compare` b =
-     (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
-     (srcSpanEnd   a `compare` srcSpanEnd   b)
-
+     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
+     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)
 
 instance Outputable RealSrcSpan where
     ppr span

compiler/cmm/CmmCommonBlockElim.hs

@@ -13,7 +13,7 @@ import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl hiding (ChangeFlag)
 import Data.Bits
-import Data.Maybe (fromJust, fromMaybe)
+import Data.Maybe (fromMaybe)
 import qualified Data.List as List
 import Data.Word
 import Outputable

compiler/coreSyn/CoreFVs.lhs

@@ -254,7 +254,7 @@ exprOrphNames e
     go (Coercion co)        = orphNamesOfCo co
     go (App e1 e2)          = go e1 `unionNameSets` go e2
     go (Lam v e)            = go e `delFromNameSet` idName v
-    go (Tick _ e)         = go e
+    go (Tick _ e)           = go e
     go (Cast e co)          = go e `unionNameSets` orphNamesOfCo co
     go (Let (NonRec _ r) e) = go e `unionNameSets` go r
     go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSets` go e

compiler/coreSyn/CorePrep.lhs

@@ -53,6 +53,8 @@ import Outputable
 import Platform
 import FastString
 import Config
+import Name             ( NamedThing(..), nameSrcSpan )
+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import Data.Bits
 import Data.List        ( mapAccumL )
 import Control.Monad
@@ -157,13 +159,14 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 %************************************************************************
 
 \begin{code}
-corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram
-corePrepPgm dflags hsc_env binds data_tycons = do
+corePrepPgm :: HscEnv -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram
+corePrepPgm hsc_env mod_loc binds data_tycons = do
+    let dflags = hsc_dflags hsc_env
     showPass dflags "CorePrep"
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
 
-    let implicit_binds = mkDataConWorkers data_tycons
+    let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
             -- NB: we must feed mkImplicitBinds through corePrep too
             -- so that they are suitably cloned and eta-expanded
 
@@ -194,13 +197,23 @@ corePrepTopBinds initialCorePrepEnv binds
                                binds' <- go env' binds
                                return (bind' `appendFloats` binds')
 
-mkDataConWorkers :: [TyCon] -> [CoreBind]
+mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
 -- See Note [Data constructor workers]
-mkDataConWorkers data_tycons
-  = [ NonRec id (Var id)        -- The ice is thin here, but it works
-    | tycon <- data_tycons,     -- CorePrep will eta-expand it
+mkDataConWorkers dflags mod_loc data_tycons
+  = [ NonRec cid (tick_it $ Var cid) -- The ice is thin here, but it works
+    | tycon <- data_tycons,          -- CorePrep will eta-expand it
       data_con <- tyConDataCons tycon,
-      let id = dataConWorkId data_con ]
+      let cid = dataConWorkId data_con
+          name = getName data_con
+          span = case nameSrcSpan name of
+            RealSrcSpan span -> span
+            UnhelpfulSpan _  -> case ml_hs_file mod_loc of
+              Just file -> realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+              Nothing   -> realSrcLocSpan $ mkRealSrcLoc (fsLit "???") 1 1
+          nameStr = showSDoc dflags (ppr name)
+          tick_it | gopt Opt_Debug dflags = Tick (SourceNote span nameStr)
+                  | otherwise             = id
+    ]
 \end{code}
 
 Note [Floating out of top level bindings]

compiler/coreSyn/CoreSubst.lhs

@@ -966,6 +966,9 @@ simple_app subst (Lam b e) (a:as)
   where
     (subst', b') = subst_opt_bndr subst b
     b2 = add_info subst' b b'
+simple_app subst (Tick t e) as
+  | tickishFloatable t
+  = mkTick t $ simple_app subst e as
 simple_app subst e as
   = foldl App (simple_opt_expr subst e) as
 

compiler/coreSyn/CoreSyn.lhs

@@ -44,8 +44,10 @@ module CoreSyn (
         isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
         isRuntimeArg, isRuntimeVar,
 
-        tickishCounts, tickishScoped, tickishIsCode, mkNoCount, mkNoScope,
-        tickishCanSplit,
+        tickishCounts, tickishScoped, tickishSoftScope, tickishFloatable,
+        tickishCanSplit, mkNoCount, mkNoScope,
+        tickishIsCode, tickishIgnoreCheap,
+        tickishContains,
 
         -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
@@ -105,6 +107,7 @@ import DynFlags
 import FastString
 import Outputable
 import Util
+import SrcLoc     ( RealSrcSpan, containsSpan )
 
 import Data.Data hiding (TyCon)
 import Data.Int
@@ -472,6 +475,30 @@ data Tickish id =
                                 -- Note [substTickish] in CoreSubst.
     }
 
+  -- | A source note.
+  --
+  -- In contrast to other ticks, source notes are pure annotations:
+  -- Their presence should neither influence compilation nor
+  -- execution.
+  --
+  -- The semantics are given by causality: The presence of a source
+  -- note means that a local change in the referenced source code span
+  -- *might* provoke the meaning of generated code to change. On the
+  -- flip-side, results of annotated code *must* be invariant against
+  -- changes to all source code *except* the spans referenced in the
+  -- source notes.
+  --
+  -- Therefore extending the scope of any given source note is always
+  -- valid. Note that it is still undesirable though, as this reduces
+  -- their usefulness for debugging and profiling. Therefore we will
+  -- generally try only to make use of this property where it is
+  -- neccessary to enable optimizations.
+  | SourceNote
+    { sourceSpan :: RealSrcSpan -- ^ Source covered
+    , sourceName :: String      -- ^ Name for source location
+                                --   (uses same names as CCs)
+    }
+
   deriving (Eq, Ord, Data, Typeable)
 
 
@@ -488,36 +515,124 @@ tickishCounts :: Tickish id -> Bool
 tickishCounts n@ProfNote{} = profNoteCount n
 tickishCounts HpcTick{}    = True
 tickishCounts Breakpoint{} = True
+tickishCounts _            = False
 
+-- | Returns @True@ if code covered by this tick should be guaranteed to
+-- stay covered. Note that this still allows code transformations
+-- inside the tick scope, as long as the result of these
+-- transformations are still covered by this tick. For example
+--
+--   let x = tick<...> (let y = foo in bar) in baz
+--     ===>
+--   let x = tick<...> bar; y = tick<...> foo in baz
+--
+-- Is a valid transformation as far as "bar" and "foo" is concerned,
+-- because both still are scoped over by the tick.
 tickishScoped :: Tickish id -> Bool
 tickishScoped n@ProfNote{} = profNoteScope n
 tickishScoped HpcTick{}    = False
 tickishScoped Breakpoint{} = True
    -- Breakpoints are scoped: eventually we're going to do call
    -- stacks, but also this helps prevent the simplifier from moving
    -- breakpoints around and changing their result type (see #1531).
+tickishScoped SourceNote{} = True
+
+-- | Returns @True@ for a scoped tick (@tickishScoped@) that allows
+-- inserting new cost into its execution scope. For example, this
+-- allows floating ticks up in a number of cases:
+--
+--   case foo of x -> tick<...> bar
+--     ==>
+--   tick<...> case foo of x -> bar
+--
+-- This can be important in order to expose optimization
+-- opportunities. Note that in constrast to @tickishScoped@, we
+-- consider execution scope and costs (cost-centre semantics), so the
+-- following unfolding is allowed regardless of this flag:
+--
+--   let x = foo in tick<...> x
+--     ==>
+--   tick<...> foo
+--
+-- This is because even though new code was inserted into the lexical
+-- scope of the tick, the execution cost covered has actually been
+-- reduced (by the need to call through "x" to get to "foo").
+tickishSoftScope :: Tickish id -> Bool
+tickishSoftScope SourceNote{} = True
+tickishSoftScope HpcTick{}    = True
+tickishSoftScope _tickish     = False  -- all the rest for now
+
+-- | Returns @True@ for ticks that can be floated upwards easily even
+-- where it might change execution counts, such as:
+--
+--   Just (tick<...> foo)
+--     ==>
+--   tick<...> (Just foo)
+--
+-- This is a combination of @tickishSoftScope@ and
+-- @tickishCounts@. Note that in principle splittable ticks can become
+-- floatable using @mkNoTick@ -- even though there's currently no
+-- tickish for which that is the case.
+tickishFloatable :: Tickish id -> Bool
+tickishFloatable t = tickishSoftScope t && not (tickishCounts t)
+
+-- | For a tick that is both counting /and/ scoping, this function
+-- returns @True@ if it can be split into its (tick, scope) parts
+-- using 'mkNoScope' and 'mkNoTick' respectively.
+tickishCanSplit :: Tickish id -> Bool
+tickishCanSplit t | not (tickishCounts t) || not (tickishScoped t)
+                           = panic "tickishCanSplit: Split undefined!"
+tickishCanSplit ProfNote{} = True
+tickishCanSplit _          = False
 
 mkNoCount :: Tickish id -> Tickish id
-mkNoCount n@ProfNote{} = n {profNoteCount = False}
-mkNoCount Breakpoint{} = panic "mkNoCount: Breakpoint" -- cannot split a BP
-mkNoCount HpcTick{}    = panic "mkNoCount: HpcTick"
+mkNoCount n | not (tickishCounts n)   = n
+            | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"
+mkNoCount n@ProfNote{}   = n {profNoteCount = False}
+mkNoCount _                           = panic "mkNoCount: Undefined split!"
 
 mkNoScope :: Tickish id -> Tickish id
+mkNoScope n | not (tickishScoped n)   = n
+            | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
 mkNoScope n@ProfNote{} = n {profNoteScope = False}
-mkNoScope Breakpoint{} = panic "mkNoScope: Breakpoint" -- cannot split a BP
-mkNoScope HpcTick{}    = panic "mkNoScope: HpcTick"
+mkNoScope _                           = panic "mkNoScope: Undefined split!"
 
--- | Return True if this source annotation compiles to some code, or will
--- disappear before the backend.
+-- | Return @True@ if this source annotation compiles to some backend
+-- code. Without this flag, the tickish is seen as a simple annotation
+-- that does not have any associated execution cost.
 tickishIsCode :: Tickish id -> Bool
-tickishIsCode _tickish = True  -- all of them for now
-
--- | Return True if this Tick can be split into (tick,scope) parts with
--- 'mkNoScope' and 'mkNoCount' respectively.
-tickishCanSplit :: Tickish Id -> Bool
-tickishCanSplit Breakpoint{} = False
-tickishCanSplit HpcTick{}    = False
-tickishCanSplit _ = True
+tickishIsCode SourceNote{} = False
+tickishIsCode _tickish     = True  -- all the rest for now
+
+-- | Whether the ticks should be removed on expressions that are cheap
+-- to the point of having no associated runtime costs whatsoever. For
+-- example in the following examples, the tick could be eliminated
+-- completely:
+--
+--   f (tick<...> 1)
+--   f (tick<...> e)
+--
+-- as literals or variables don't carry any cost on their own (even
+-- though their usage might well cause cost). Along the same lines, we
+-- can do the following for our ticks:
+--
+--   let a = tick<...> A e0 e1 in foo
+--     ==>
+--   let a = A (tick<...> e0) (tick<...> e1) in foo
+--
+-- As we see the actual allocation cost coming from the usage site
+-- (the let) rather then the constructor itself.
+tickishIgnoreCheap :: Tickish id -> Bool
+tickishIgnoreCheap ProfNote{}          = True
+tickishIgnoreCheap _other              = False
+
+-- | Returns whether one tick "contains" the other one, therefore
+-- making the second tick redundant.
+tickishContains :: Tickish Id -> Tickish Id -> Bool
+tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
+  = n1 == n2 && containsSpan sp1 sp2
+tickishContains t1 t2
+  = t1 == t2
 \end{code}
 
 
@@ -1375,8 +1490,8 @@ seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 seqExpr (Cast e co)     = seqExpr e `seq` seqCo co
-seqExpr (Tick n e)    = seqTickish n `seq` seqExpr e
-seqExpr (Type t)       = seqType t
+seqExpr (Tick n e)      = seqTickish n `seq` seqExpr e
+seqExpr (Type t)        = seqType t
 seqExpr (Coercion co)   = seqCo co
 
 seqExprs :: [CoreExpr] -> ()
@@ -1387,6 +1502,7 @@ seqTickish :: Tickish Id -> ()
 seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()
 seqTickish HpcTick{} = ()
 seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids
+seqTickish SourceNote{} = ()
 
 seqBndr :: CoreBndr -> ()
 seqBndr b = b `seq` ()

compiler/coreSyn/CoreUnfold.lhs

@@ -234,7 +234,8 @@ calcUnfoldingGuidance
         -> CoreExpr    -- Expression to look at
         -> (Arity, UnfoldingGuidance)
 calcUnfoldingGuidance dflags expr
-  = case collectBinders expr of { (bndrs, body) ->
+  = case stripTicksTop (not . tickishIsCode) expr of { (_, expr') ->
+    case collectBinders expr' of { (bndrs, body) ->
     let
         bOMB_OUT_SIZE = ufCreationThreshold dflags
                -- Bomb out if size gets bigger than this
@@ -264,7 +265,7 @@ calcUnfoldingGuidance dflags expr
                        | otherwise             = (+)
              -- See Note [Function and non-function discounts]
     in
-    (n_val_bndrs, guidance) }
+    (n_val_bndrs, guidance) } }
 \end{code}
 
 Note [Computing the size of an expression]