Source notes (Core support)
authorPeter Wortmann <scpmw@leeds.ac.uk>
Mon, 1 Dec 2014 19:21:47 +0000 (20:21 +0100)
committerAustin Seipp <austin@well-typed.com>
Tue, 16 Dec 2014 21:01:40 +0000 (15:01 -0600)
This patch introduces "SourceNote" tickishs that link Core to the
source code that generated it. The idea is to retain these source code
links throughout code transformations so we can eventually relate
object code all the way back to the original source (which we can,
say, encode as DWARF information to allow debugging).  We generate
these SourceNotes like other tickshs in the desugaring phase. The
activating command line flag is "-g", consistent with the flag other
compilers use to decide DWARF generation.

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 -- which at this point is GHC, all libraries and
nofib. Also note that this pass creates *lots* of tick nodes, which we
reduce somewhat by removing duplicated and overlapping source
ticks. This will still cause significant Tick "clumps" - a possible
future optimization could be to make Tick carry a list of Tickishs
instead of one at a time.

(From Phabricator D169)

29 files changed:
compiler/basicTypes/SrcLoc.hs
compiler/coreSyn/CoreArity.hs
compiler/coreSyn/CoreFVs.hs
compiler/coreSyn/CorePrep.hs
compiler/coreSyn/CoreSubst.hs
compiler/coreSyn/CoreSyn.hs
compiler/coreSyn/CoreUnfold.hs
compiler/coreSyn/CoreUtils.hs
compiler/coreSyn/PprCore.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/simplCore/CSE.hs
compiler/simplCore/FloatIn.hs
compiler/simplCore/FloatOut.hs
compiler/simplCore/OccurAnal.hs
compiler/simplCore/SetLevels.hs
compiler/simplCore/SimplCore.hs
compiler/simplCore/SimplEnv.hs
compiler/simplCore/SimplUtils.hs
compiler/simplCore/Simplify.hs
compiler/specialise/Rules.hs
compiler/specialise/SpecConstr.hs
compiler/stgSyn/CoreToStg.hs
compiler/utils/OrdList.hs

index 8e17561..03e415b 100644 (file)
@@ -43,7 +43,7 @@ module SrcLoc (
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        showUserSpan,
+        showUserSpan, pprUserRealSpan,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -53,6 +53,7 @@ module SrcLoc (
 
         -- ** Predicates on SrcSpan
         isGoodSrcSpan, isOneLineSpan,
+        containsSpan,
 
         -- * Located
         Located,
@@ -264,8 +265,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
@@ -348,9 +349,19 @@ 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 where spans are equal.
+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)
+
 {-
-************************************************************************
-*                                                                      *
+%************************************************************************
+%*                                                                      *
 \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
 *                                                                      *
 ************************************************************************
@@ -418,11 +429,12 @@ srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
 ************************************************************************
 -}
 
--- 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 Show RealSrcLoc where
   show (SrcLoc filename row col)
index 5128891..07ef398 100644 (file)
@@ -822,6 +822,23 @@ Note that SCCs are not treated specially by etaExpand.  If we have
         etaExpand 2 (\x -> scc "foo" e)
         = (\xy -> (scc "foo" e) y)
 So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
+Note [Eta expansion and source notes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+CorePrep puts floatable ticks outside of value applications, but not
+type applications. As a result we might be trying to eta-expand an
+expression like
+
+  (src<...> v) @a
+
+which we want to lead to code like
+
+  \x -> src<...> v @a x
+
+This means that we need to look through type applications and be ready
+to re-add floats on the top.
+
 -}
 
 -- | @etaExpand n us e ty@ returns an expression with
@@ -854,13 +871,21 @@ etaExpand n orig_expr
     go 0 expr = expr
     go n (Lam v body) | isTyVar v = Lam v (go n     body)
                       | otherwise = Lam v (go (n-1) body)
-    go n (Cast expr co) = Cast (go n expr) co
-    go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
-                          etaInfoAbs etas (etaInfoApp subst' expr etas)
-                        where
-                            in_scope = mkInScopeSet (exprFreeVars expr)
-                            (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
-                            subst' = mkEmptySubst in_scope'
+    go n (Cast expr co)           = Cast (go n expr) co
+    go n expr
+      = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
+        retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)
+      where
+          in_scope = mkInScopeSet (exprFreeVars expr)
+          (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
+          subst' = mkEmptySubst in_scope'
+
+          -- Find ticks behind type apps.
+          -- See Note [Eta expansion and source notes]
+          (expr', args) = collectArgs expr
+          (ticks, expr'') = stripTicksTop tickishFloatable expr'
+          sexpr = foldl App expr'' args
+          retick expr = foldr mkTick expr ticks
 
                                 -- Wrapper    Unwrapper
 --------------
index af475ba..cce313d 100644 (file)
@@ -248,7 +248,7 @@ exprOrphNames e
     go (Coercion co)        = orphNamesOfCo co
     go (App e1 e2)          = go e1 `unionNameSet` 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 `unionNameSet` orphNamesOfCo co
     go (Let (NonRec _ r) e) = go e `unionNameSet` go r
     go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSet` go e
index 62efae2..f1bdd73 100644 (file)
@@ -54,6 +54,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
@@ -158,13 +160,14 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 ************************************************************************
 -}
 
-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
 
@@ -195,14 +198,26 @@ corePrepTopBinds initialCorePrepEnv binds
                                binds' <- go env' binds
                                return (bind' `appendFloats` binds')
 
-mkDataConWorkers :: [TyCon] -> [CoreBind]
+mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
 -- See Note [Data constructor workers]
 -- c.f. Note [Injecting implicit bindings] in TidyPgm
-mkDataConWorkers data_tycons
-  = [ NonRec id (Var id)        -- The ice is thin here, but it works
+mkDataConWorkers dflags mod_loc data_tycons
+  = [ NonRec id (tick_it (getName data_con) (Var id))
+                                -- 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 id = dataConWorkId data_con
+    ]
+ where
+   -- 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
+     | not (gopt Opt_Debug dflags)           = id
+     | RealSrcSpan span <- nameSrcSpan name  = tick span
+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)
+     | otherwise                             = tick (span1 "???")
+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))
+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
 
 {-
 Note [Floating out of top level bindings]
@@ -579,7 +594,7 @@ rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 -- Remove top level lambdas by let-binding
 
 rhsToBody (Tick t expr)
-  | not (tickishScoped t)  -- we can only float out of non-scoped annotations
+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
   = do { (floats, expr') <- rhsToBody expr
        ; return (floats, Tick t expr') }
 
index 82e18ca..b381dc8 100644 (file)
@@ -372,7 +372,7 @@ subst_expr subst expr
     go (Coercion co)   = Coercion (substCo subst co)
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
-    go (Tick tickish e) = Tick (substTickish subst tickish) (go e)
+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
     go (Cast e co)     = Cast (go e) (substCo subst co)
        -- Do not optimise even identity coercions
        -- Reason: substitution applies to the LHS of RULES, and
@@ -892,7 +892,7 @@ simple_opt_expr subst expr
     go (Type ty)        = Type     (substTy subst ty)
     go (Coercion co)    = Coercion (optCoercion (getCvSubst subst) co)
     go (Lit lit)        = Lit lit
-    go (Tick tickish e) = Tick (substTickish subst tickish) (go e)
+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
     go (Cast e co)      | isReflCo co' = go e
                         | otherwise    = Cast (go e) co'
                         where
@@ -956,6 +956,10 @@ simple_app subst (Var v) as
   | isCompulsoryUnfolding (idUnfolding v)
   -- See Note [Unfold compulsory unfoldings in LHSs]
   =  simple_app subst (unfoldingTemplate (idUnfolding v)) as
+simple_app subst (Tick t e) as
+  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
+  | t `tickishScopesLike` SoftScope
+  = mkTick t $ simple_app subst e as
 simple_app subst e as
   = foldl App (simple_opt_expr subst e) as
 
@@ -1348,36 +1352,44 @@ Currently, it is used in Rules.match, and is required to make
 "map coerce = coerce" match.
 -}
 
-exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr)
+exprIsLambda_maybe :: InScopeEnv -> CoreExpr
+                      -> Maybe (Var, CoreExpr,[Tickish Id])
     -- See Note [exprIsLambda_maybe]
 
 -- The simple case: It is a lambda already
 exprIsLambda_maybe _ (Lam x e)
-    = Just (x, e)
+    = Just (x, e, [])
+
+-- Still straightforward: Ticks that we can float out of the way
+exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+    | tickishFloatable t
+    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+    = Just (x, e, t:ts)
 
 -- Also possible: A casted lambda. Push the coercion inside
 exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
-    | Just (x, e) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+    | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
     -- Only do value lambdas.
     -- this implies that x is not in scope in gamma (makes this code simpler)
     , not (isTyVar x) && not (isCoVar x)
     , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
-    , let res = pushCoercionIntoLambda in_scope_set x e co
-    = -- pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e, ppr co, ppr res])
+    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
+    , let res = Just (x',e',ts)
+    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
       res
 
 -- Another attempt: See if we find a partial unfolding
 exprIsLambda_maybe (in_scope_set, id_unf) e
-    | (Var f, as) <- collectArgs e
+    | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
     , idArity f > length (filter isValArg as)
     -- Make sure there is hope to get a lambda
     , Just rhs <- expandUnfolding_maybe (id_unf f)
     -- Optimize, for beta-reduction
     , let e' =  simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
     -- Recurse, because of possible casts
-    , Just (x', e'') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
-    , let res = Just (x', e'')
-    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr res])
+    , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+    , let res = Just (x', e'', ts++ts')
+    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
       res
 
 exprIsLambda_maybe _ _e
index 0c6ee7c..1a1f840 100644 (file)
@@ -8,7 +8,8 @@
 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
 module CoreSyn (
         -- * Main data types
-        Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..),
+        Expr(..), Alt, Bind(..), AltCon(..), Arg,
+        Tickish(..), TickishScoping(..), TickishPlacement(..),
         CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
 
@@ -31,13 +32,15 @@ module CoreSyn (
         -- ** Simple 'Expr' access functions and predicates
         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
-        collectArgs, flattenBinds,
+        collectArgs, collectArgsTicks, flattenBinds,
 
         isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
         isRuntimeArg, isRuntimeVar,
 
-        tickishCounts, tickishScoped, tickishIsCode, mkNoCount, mkNoScope,
-        tickishCanSplit,
+        tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable,
+        tickishCanSplit, mkNoCount, mkNoScope,
+        tickishIsCode, tickishPlace,
+        tickishContains,
 
         -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
@@ -62,7 +65,7 @@ module CoreSyn (
         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
 
         -- ** Operations on annotated expressions
-        collectAnnArgs,
+        collectAnnArgs, collectAnnArgsTicks,
 
         -- ** Operations on annotations
         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
@@ -97,6 +100,7 @@ import DynFlags
 import FastString
 import Outputable
 import Util
+import SrcLoc     ( RealSrcSpan, containsSpan )
 
 import Data.Data hiding (TyCon)
 import Data.Int
@@ -466,6 +470,28 @@ data Tickish id =
                                 -- Note [substTickish] in CoreSubst.
     }
 
+  -- | A source note.
+  --
+  -- 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 will possibly provoke
+  -- the generated code to change. On the flip-side, the functionality
+  -- of annotated code *must* be invariant against changes to all
+  -- source code *except* the spans referenced in the source notes
+  -- (see "Causality of optimized Haskell" paper for details).
+  --
+  -- 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)
 
 
@@ -477,41 +503,200 @@ data Tickish id =
 -- However, we still allow the simplifier to increase or decrease
 -- sharing, so in practice the actual number of ticks may vary, except
 -- that we never change the value from zero to non-zero or vice versa.
---
 tickishCounts :: Tickish id -> Bool
 tickishCounts n@ProfNote{} = profNoteCount n
 tickishCounts HpcTick{}    = True
 tickishCounts Breakpoint{} = True
-
-tickishScoped :: Tickish id -> Bool
-tickishScoped n@ProfNote{} = profNoteScope n
-tickishScoped HpcTick{}    = False
-tickishScoped Breakpoint{} = True
+tickishCounts _            = False
+
+
+-- | Specifies the scoping behaviour of ticks. This governs the
+-- behaviour of ticks that care about the covered code and the cost
+-- associated with it. Important for ticks relating to profiling.
+data TickishScoping =
+    -- | No scoping: The tick does not care about what code it
+    -- covers. Transformations can freely move code inside as well as
+    -- outside without any additional annotation obligations
+    NoScope
+
+    -- | Soft scoping: We want all code that is covered to stay
+    -- covered.  Note that this scope type does not forbid
+    -- transformations from happening, as as long as all results of
+    -- the transformations are still covered by this tick or a copy of
+    -- it. 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.
+    --
+    -- Note though that one might object to the "let" not being
+    -- covered by the tick any more. However, we are generally lax
+    -- with this - constant costs don't matter too much, and given
+    -- that the "let" was effectively merged we can view it as having
+    -- lost its identity anyway.
+    --
+    -- Also note that this scoping behaviour allows floating a tick
+    -- "upwards" in pretty much any situation. For example:
+    --
+    --   case foo of x -> tick<...> bar
+    --     ==>
+    --   tick<...> case foo of x -> bar
+    --
+    -- While this is always leagl, we want to make a best effort to
+    -- only make us of this where it exposes transformation
+    -- opportunities.
+  | SoftScope
+
+    -- | Cost centre scoping: We don't want any costs to move to other
+    -- cost-centre stacks. This means we not only want no code or cost
+    -- to get moved out of their cost centres, but we also object to
+    -- code getting associated with new cost-centre ticks - or
+    -- changing the order in which they get applied.
+    --
+    -- A rule of thumb is that we don't want any code to gain new
+    -- annotations. However, there are notable exceptions, for
+    -- example:
+    --
+    --   let f = \y -> foo in tick<...> ... (f x) ...
+    --     ==>
+    --   tick<...> ... foo[x/y] ...
+    --
+    -- In-lining lambdas like this is always legal, because inlining a
+    -- function does not change the cost-centre stack when the
+    -- function is called.
+  | CostCentreScope
+
+  deriving (Eq)
+
+-- | Returns the intended scoping rule for a Tickish
+tickishScoped :: Tickish id -> TickishScoping
+tickishScoped n@ProfNote{}
+  | profNoteScope n        = CostCentreScope
+  | otherwise              = NoScope
+tickishScoped HpcTick{}    = NoScope
+tickishScoped Breakpoint{} = CostCentreScope
    -- 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{} = SoftScope
+
+-- | Returns whether the tick scoping rule is at least as permissive
+-- as the given scoping rule.
+tickishScopesLike :: Tickish id -> TickishScoping -> Bool
+tickishScopesLike t scope = tickishScoped t `like` scope
+  where NoScope         `like` _               = True
+        _               `like` NoScope         = False
+        SoftScope       `like` _               = True
+        _               `like` SoftScope       = False
+        CostCentreScope `like` _               = True
+
+-- | 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 = t `tickishScopesLike` SoftScope && not (tickishCounts t)
+
+-- | Returns @True@ for a tick that is both counting /and/ scoping and
+-- can be split into its (tick, scope) parts using 'mkNoScope' and
+-- 'mkNoTick' respectively.
+tickishCanSplit :: Tickish id -> Bool
+tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}
+                   = 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@ProfNote{} = n {profNoteScope = False}
-mkNoScope Breakpoint{} = panic "mkNoScope: Breakpoint" -- cannot split a BP
-mkNoScope HpcTick{}    = panic "mkNoScope: HpcTick"
-
--- | Return True if this source annotation compiles to some code, or will
--- disappear before the backend.
+mkNoScope n | tickishScoped n == NoScope  = n
+            | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"
+mkNoScope n@ProfNote{}                    = n {profNoteScope = False}
+mkNoScope _                               = panic "mkNoScope: Undefined split!"
+
+-- | 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 evaluation code.
+--
+-- What this means that we are allowed to disregard the tick if doing
+-- so means that we can skip generating any code in the first place. A
+-- typical example is top-level bindings:
+--
+--   foo = tick<...> \y -> ...
+--     ==>
+--   foo = \y -> tick<...> ...
+--
+-- Here there is just no operational difference between the first and
+-- the second version. Therefore code generation should simply
+-- translate the code as if it found the latter.
 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
+
+
+-- | Governs the kind of expression that the tick gets placed on when
+-- annotating for example using @mkTick@. If we find that we want to
+-- put a tickish on an expression ruled out here, we try to float it
+-- inwards until we find a suitable expression.
+data TickishPlacement =
+
+    -- | Place ticks exactly on run-time expressions. We can still
+    -- move the tick through pure compile-time constructs such as
+    -- other ticks, casts or type lambdas. This is the most
+    -- restrictive placement rule for ticks, as all tickishs have in
+    -- common that they want to track runtime processes. The only
+    -- legal placement rule for counting ticks.
+    PlaceRuntime
+
+    -- | As @PlaceRuntime@, but we float the tick through all
+    -- lambdas. This makes sense where there is little difference
+    -- between annotating the lambda and annotating the lambda's code.
+  | PlaceNonLam
+
+    -- | In addition to floating through lambdas, cost-centre style
+    -- tickishs can also be moved from constructors, non-function
+    -- variables and literals. For example:
+    --
+    --   let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
+    --
+    -- Neither the constructor application, the variable or the
+    -- literal are likely to have any cost worth mentioning. And even
+    -- if y names a thunk, the call would not care about the
+    -- evaluation context. Therefore removing all annotations in the
+    -- above example is safe.
+  | PlaceCostCentre
+
+  deriving (Eq)
+
+-- | Placement behaviour we want for the ticks
+tickishPlace :: Tickish id -> TickishPlacement
+tickishPlace n@ProfNote{}
+  | profNoteCount n        = PlaceRuntime
+  | otherwise              = PlaceCostCentre
+tickishPlace HpcTick{}     = PlaceRuntime
+tickishPlace Breakpoint{}  = PlaceRuntime
+tickishPlace SourceNote{}  = PlaceNonLam
+
+-- | Returns whether one tick "contains" the other one, therefore
+-- making the second tick redundant.
+tickishContains :: Eq b => Tickish b -> Tickish b -> Bool
+tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
+  = n1 == n2 && containsSpan sp1 sp2
+tickishContains t1 t2
+  = t1 == t2
 
 {-
 ************************************************************************
@@ -1324,6 +1509,19 @@ collectArgs expr
     go (App f a) as = go f (a:as)
     go e         as = (e, as)
 
+-- | Like @collectArgs@, but also collects looks through floatable
+-- ticks if it means that we can find more arguments.
+collectArgsTicks :: (Tickish Id -> Bool) -> Expr b
+                 -> (Expr b, [Arg b], [Tickish Id])
+collectArgsTicks skipTick expr
+  = go expr [] []
+  where
+    go (App f a)  as ts = go f (a:as) ts
+    go (Tick t e) as ts
+      | skipTick t      = go e as (t:ts)
+    go e          as ts = (e, as, reverse ts)
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1388,8 +1586,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] -> ()
@@ -1400,6 +1598,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` ()
@@ -1468,6 +1667,16 @@ collectAnnArgs expr
     go (_, AnnApp f a) as = go f (a:as)
     go e               as = (e, as)
 
+collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a
+                       -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])
+collectAnnArgsTicks tickishOk expr
+  = go expr [] []
+  where
+    go (_, AnnApp f a)  as ts = go f (a:as) ts
+    go (_, AnnTick t e) as ts | tickishOk t
+                              = go e as (t:ts)
+    go e                as ts = (e, as, reverse ts)
+
 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 deAnnotate (_, e) = deAnnotate' e
 
index dc9f95e..1dbd5ed 100644 (file)
@@ -328,6 +328,9 @@ calcUnfoldingGuidance
         :: DynFlags
         -> CoreExpr    -- Expression to look at
         -> UnfoldingGuidance
+calcUnfoldingGuidance dflags (Tick t expr)
+  | not (tickishIsCode t)  -- non-code ticks don't matter for unfolding
+  = calcUnfoldingGuidance dflags expr
 calcUnfoldingGuidance dflags expr
   = case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of
       TooBig -> UnfNever
@@ -576,6 +579,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
         | otherwise                      = size_up arg  `addSizeNSD`
                                            size_up_app fun (arg:args) voids
     size_up_app (Var fun)     args voids = size_up_call fun args voids
+    size_up_app (Tick _ expr) args voids = size_up_app expr args voids
     size_up_app other         args voids = size_up other `addSizeN` (length args - voids)
 
     ------------
@@ -623,8 +627,9 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
     isRealWorldId id = idType id `eqType` realWorldStatePrimTy
 
     -- an expression of type State# RealWorld must be a variable
-    isRealWorldExpr (Var id) = isRealWorldId id
-    isRealWorldExpr _        = False
+    isRealWorldExpr (Var id)   = isRealWorldId id
+    isRealWorldExpr (Tick _ e) = isRealWorldExpr e
+    isRealWorldExpr _          = False
 
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
index ffb3275..c5340b8 100644 (file)
@@ -12,7 +12,7 @@ Utility functions on @Core@ syntax
 module CoreUtils (
         -- * Constructing expressions
         mkCast,
-        mkTick, mkTickNoHNF, tickHNFArgs,
+        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
         bindNonRec, needsCaseBinding,
         mkAltExpr,
 
@@ -33,14 +33,17 @@ module CoreUtils (
         CoreStats(..), coreBindsStats,
 
         -- * Equality
-        cheapEqExpr, eqExpr,
+        cheapEqExpr, cheapEqExpr', eqExpr,
 
         -- * Eta reduction
         tryEtaReduce,
 
         -- * Manipulating data constructors and types
         applyTypeToArgs, applyTypeToArg,
-        dataConRepInstPat, dataConRepFSInstPat
+        dataConRepInstPat, dataConRepFSInstPat,
+
+        -- * Working with ticks
+        stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
     ) where
 
 #include "HsVersions.h"
@@ -70,7 +73,13 @@ import Maybes
 import Platform
 import Util
 import Pair
+import Data.Function       ( on )
 import Data.List
+import Control.Applicative
+#if __GLASGOW_HASKELL__ < 709
+import Data.Traversable    ( traverse )
+#endif
+import OrdList
 
 {-
 ************************************************************************
@@ -211,6 +220,9 @@ mkCast (Cast expr co2) co
                    , ptext (sLit "co:") <+> ppr co ]) )
     mkCast expr (mkTransCo co2 co)
 
+mkCast (Tick t expr) co
+   = Tick t (mkCast expr co)
+
 mkCast expr co
   = let Pair from_ty _to_ty = coercionKind co in
 --    if to_ty `eqType` from_ty
@@ -222,48 +234,84 @@ mkCast expr co
 -- | Wraps the given expression in the source annotation, dropping the
 -- annotation if possible.
 mkTick :: Tickish Id -> CoreExpr -> CoreExpr
+mkTick t orig_expr = mkTick' id id orig_expr
+ where
+  -- Some ticks (cost-centres) can be split in two, with the
+  -- non-counting part having laxer placement properties.
+  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
 
-mkTick t (Var x)
-  | isFunTy (idType x) = Tick t (Var x)
-  | otherwise
-  = if tickishCounts t
-       then if tickishScoped t && tickishCanSplit t
-               then Tick (mkNoScope t) (Var x)
-               else Tick t (Var x)
-       else Var x
-
-mkTick t (Cast e co)
-  = Cast (mkTick t e) co -- Move tick inside cast
-
-mkTick _ (Coercion co) = Coercion co
-
-mkTick t (Lit l)
-  | not (tickishCounts t) = Lit l
-
-mkTick t expr@(App f arg)
-  | not (isRuntimeArg arg) = App (mkTick t f) arg
-  | isSaturatedConApp expr
-    = if not (tickishCounts t)
-         then tickHNFArgs t expr
-         else if tickishScoped t && tickishCanSplit t
-                 then Tick (mkNoScope t) (tickHNFArgs (mkNoCount t) expr)
-                 else Tick t expr
-
-mkTick t (Lam x e)
-     -- if this is a type lambda, or the tick does not count entries,
-     -- then we can push the tick inside:
-  | not (isRuntimeVar x) || not (tickishCounts t) = Lam x (mkTick t e)
-     -- if it is both counting and scoped, we split the tick into its
-     -- two components, keep the counting tick on the outside of the lambda
-     -- and push the scoped tick inside.  The point of this is that the
-     -- counting tick can probably be floated, and the lambda may then be
-     -- in a position to be beta-reduced.
-  | tickishScoped t && tickishCanSplit t
-         = Tick (mkNoScope t) (Lam x (mkTick (mkNoCount t) e))
-     -- just a counting tick: leave it on the outside
-  | otherwise        = Tick t (Lam x e)
-
-mkTick t other = Tick t other
+  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)
+          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)
+          -> CoreExpr               -- ^ current expression
+          -> CoreExpr
+  mkTick' top rest expr = case expr of
+
+    -- Cost centre ticks should never be reordered relative to each
+    -- other. Therefore we can stop whenever two collide.
+    Tick t2 e
+      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr
+
+    -- Otherwise we assume that ticks of different placements float
+    -- through each other.
+      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e
+
+    -- For annotations this is where we make sure to not introduce
+    -- redundant ticks.
+      | tickishContains t t2              -> mkTick' top rest e
+      | tickishContains t2 t              -> orig_expr
+      | otherwise                         -> mkTick' top (rest . Tick t2) e
+
+    -- Ticks don't care about types, so we just float all ticks
+    -- through them. Note that it's not enough to check for these
+    -- cases top-level. While mkTick will never produce Core with type
+    -- expressions below ticks, such constructs can be the result of
+    -- unfoldings. We therefore make an effort to put everything into
+    -- the right place no matter what we start with.
+    Cast e co   -> mkTick' (top . flip Cast co) rest e
+    Coercion co -> Coercion co
+
+    Lam x e
+      -- Always float through type lambdas. Even for non-type lambdas,
+      -- floating is allowed for all but the most strict placement rule.
+      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
+      -> mkTick' (top . Lam x) rest e
+
+      -- If it is both counting and scoped, we split the tick into its
+      -- two components, often allowing us to keep the counting tick on
+      -- the outside of the lambda and push the scoped tick inside.
+      -- The point of this is that the counting tick can probably be
+      -- floated, and the lambda may then be in a position to be
+      -- beta-reduced.
+      | canSplit
+      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
+
+    App f arg
+      -- Always float through type applications.
+      | not (isRuntimeArg arg)
+      -> mkTick' (top . flip App arg) rest f
+
+      -- We can also float through constructor applications, placement
+      -- permitting. Again we can split.
+      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
+      -> if tickishPlace t == PlaceCostCentre
+         then top $ rest $ tickHNFArgs t expr
+         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
+
+    Var x
+      | not (isFunTy (idType x)) && tickishPlace t == PlaceCostCentre
+      -> orig_expr
+      | canSplit
+      -> top $ Tick (mkNoScope t) $ rest expr
+
+    Lit{}
+      | tickishPlace t == PlaceCostCentre
+      -> orig_expr
+
+    -- Catch-all: Annotate where we stand
+    _any -> top $ Tick t $ rest expr
+
+mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
+mkTicks ticks expr = foldr mkTick expr ticks
 
 isSaturatedConApp :: CoreExpr -> Bool
 isSaturatedConApp e = go e []
@@ -286,6 +334,48 @@ tickHNFArgs t e = push t e
   push t (App f arg) = App (push t f) (mkTick t arg)
   push _t e = e
 
+-- | Strip ticks satisfying a predicate from top of an expression
+stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
+stripTicksTop p = go []
+  where go ts (Tick t e) | p t = go (t:ts) e
+        go ts other            = (reverse ts, other)
+
+-- | Strip ticks satisfying a predicate from top of an expression,
+-- returning the remaining expresion
+stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
+stripTicksTopE p = go
+  where go (Tick t e) | p t = go e
+        go other            = other
+
+-- | Strip ticks satisfying a predicate from top of an expression,
+-- returning the ticks
+stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
+stripTicksTopT p = go []
+  where go ts (Tick t e) | p t = go (t:ts) e
+        go ts _                = ts
+
+-- | Completely strip ticks satisfying a predicate from an
+-- expression. Note this is O(n) in the size of the expression!
+stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
+stripTicks p expr = (fromOL ticks, expr')
+  where (ticks, expr') = go expr
+        -- Note that  OrdList (Tickish Id) is a Monoid, which makes
+        -- ((,) (OrdList (Tickish Id))) an Applicative.
+        go (App e a)        = App <$> go e <*> go a
+        go (Lam b e)        = Lam b <$> go e
+        go (Let b e)        = Let <$> go_bs b <*> go e
+        go (Case e b t as)  = Case <$> go e <*> pure b <*> pure t
+                                   <*> traverse go_a as
+        go (Cast e c)       = Cast <$> go e <*> pure c
+        go (Tick t e)
+          | p t             = let (ts, e') = go e in (t `consOL` ts, e')
+          | otherwise       = Tick t <$> go e
+        go other            = pure other
+        go_bs (NonRec b e)  = NonRec b <$> go e
+        go_bs (Rec bs)      = Rec <$> traverse go_b bs
+        go_b (b, e)         = (,) <$> pure b <*> go e
+        go_a (c,bs,e)       = (,,) <$> pure c <*> pure bs <*> go e
+
 {-
 ************************************************************************
 *                                                                      *
@@ -541,18 +631,21 @@ saturating them.
 
 Note [Tick trivial]
 ~~~~~~~~~~~~~~~~~~~
-Ticks are not trivial.  If we treat "tick<n> x" as trivial, it will be
-inlined inside lambdas and the entry count will be skewed, for
-example.  Furthermore "scc<n> x" will turn into just "x" in mkTick.
+
+Ticks are only trivial if they are pure annotations. If we treat
+"tick<n> x" as trivial, it will be inlined inside lambdas and the
+entry count will be skewed, for example.  Furthermore "scc<n> x" will
+turn into just "x" in mkTick.
 -}
 
 exprIsTrivial :: CoreExpr -> Bool
 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
-exprIsTrivial (Type _)        = True
+exprIsTrivial (Type _)         = True
 exprIsTrivial (Coercion _)     = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Tick _ _)       = False  -- See Note [Tick trivial]
+exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
+                                 -- See Note [Tick trivial]
 exprIsTrivial (Cast e _)       = exprIsTrivial e
 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
@@ -767,8 +860,9 @@ exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
 exprIsCheap' good_app (Tick t e)
   | tickishCounts t = False
   | otherwise       = exprIsCheap' good_app e
-     -- never duplicate ticks.  If we get this wrong, then HPC's entry
-     -- counts will be off (check test in libraries/hpc/tests/raytrace)
+     -- never duplicate counting ticks.  If we get this wrong, then
+     -- HPC's entry counts will be off (check test in
+     -- libraries/hpc/tests/raytrace)
 
 exprIsCheap' good_app (Let (NonRec _ b) e)
   = exprIsCheap' good_app b && exprIsCheap' good_app e
@@ -807,6 +901,10 @@ exprIsCheap' good_app other_expr        -- Applications and variables
                         -- always gives bottom; we treat this as cheap
                         -- because it certainly doesn't need to be shared!
 
+    go (Tick t e) args
+      | not (tickishCounts t) -- don't duplicate counting ticks, see above
+      = go e args
+
     go _ _ = False
 
     --------------
@@ -955,8 +1053,9 @@ expr_ok primop_ok (Case e _ _ alts)
 
 expr_ok primop_ok other_expr
   = case collectArgs other_expr of
-        (Var f, args) -> app_ok primop_ok f args
-        _             -> False
+        (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr
+                     -> app_ok primop_ok f args
+        _            -> False
 
 -----------------------------
 app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
@@ -1313,29 +1412,40 @@ c.f. add_evals in Simplify.simplAlt
 --
 -- See also 'exprIsBig'
 cheapEqExpr :: Expr b -> Expr b -> Bool
+cheapEqExpr = cheapEqExpr' (const False)
+
+-- | Cheap expression equality test, can ignore ticks by type.
+cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
+cheapEqExpr' ignoreTick = go_s
+  where go_s = go `on` stripTicksTopE ignoreTick
+        go (Var v1)   (Var v2)   = v1 == v2
+        go (Lit lit1) (Lit lit2) = lit1 == lit2
+        go (Type t1)  (Type t2)  = t1 `eqType` t2
+        go (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
 
-cheapEqExpr (Var v1)   (Var v2)   = v1==v2
-cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
-cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
+        go (App f1 a1) (App f2 a2)
+          = f1 `go_s` f2 && a1 `go_s` a2
 
-cheapEqExpr (App f1 a1) (App f2 a2)
-  = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
+        go (Cast e1 t1) (Cast e2 t2)
+          = e1 `go_s` e2 && t1 `coreEqCoercion` t2
 
-cheapEqExpr (Cast e1 t1) (Cast e2 t2)
-  = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
+        go (Tick t1 e1) (Tick t2 e2)
+          = t1 == t2 && e1 `go_s` e2
 
-cheapEqExpr _ _ = False
+        go _ _ = False
+        {-# INLINE go #-}
+{-# INLINE cheapEqExpr' #-}
 
 exprIsBig :: Expr b -> Bool
 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
 exprIsBig (Lit _)      = False
 exprIsBig (Var _)      = False
-exprIsBig (Type _)    = False
+exprIsBig (Type _)     = False
 exprIsBig (Coercion _) = False
 exprIsBig (Lam _ e)    = exprIsBig e
 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!
+exprIsBig (Tick _ e)   = exprIsBig e
 exprIsBig _            = True
 
 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
@@ -1612,9 +1722,15 @@ tryEtaReduce bndrs body
       = Just (mkCast fun co)   -- Check for any of the binders free in the result
                                -- including the accumulated coercion
 
+    go bs (Tick t e) co
+      | tickishFloatable t
+      = fmap (Tick t) $ go bs e co
+      -- Float app ticks: \x -> Tick t (e x) ==> Tick t e
+
     go (b : bs) (App fun arg) co
-      | Just co' <- ok_arg b arg co
-      = go bs fun co'
+      | Just (co', ticks) <- ok_arg b arg co
+      = fmap (flip (foldr mkTick) ticks) $ go bs fun co'
+            -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e
 
     go _ _ _  = Nothing         -- Failure!
 
@@ -1622,6 +1738,7 @@ tryEtaReduce bndrs body
     -- Note [Eta reduction conditions]
     ok_fun (App fun (Type {})) = ok_fun fun
     ok_fun (Cast fun _)        = ok_fun fun
+    ok_fun (Tick _ expr)       = ok_fun expr
     ok_fun (Var fun_id)        = ok_fun_id fun_id || all ok_lam bndrs
     ok_fun _fun                = False
 
@@ -1646,19 +1763,26 @@ tryEtaReduce bndrs body
     ok_arg :: Var              -- Of type bndr_t
            -> CoreExpr         -- Of type arg_t
            -> Coercion         -- Of kind (t1~t2)
-           -> Maybe Coercion   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
+           -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)
                                --   (and similarly for tyvars, coercion args)
+                    , [Tickish Var])
     -- See Note [Eta reduction with casted arguments]
     ok_arg bndr (Type ty) co
        | Just tv <- getTyVar_maybe ty
-       , bndr == tv  = Just (mkForAllCo tv co)
+       , bndr == tv  = Just (mkForAllCo tv co, [])
     ok_arg bndr (Var v) co
-       | bndr == v   = Just (mkFunCo Representational
-                                     (mkReflCo Representational (idType bndr)) co)
-    ok_arg bndr (Cast (Var v) co_arg) co
-       | bndr == v  = Just (mkFunCo Representational (mkSymCo co_arg) co)
+       | bndr == v   = let reflCo = mkReflCo Representational (idType bndr)
+                       in Just (mkFunCo Representational reflCo co, [])
+    ok_arg bndr (Cast e co_arg) co
+       | (ticks, Var v) <- stripTicksTop tickishFloatable e
+       , bndr == v
+       = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks)
        -- The simplifier combines multiple casts into one,
        -- so we can have a simple-minded pattern match here
+    ok_arg bndr (Tick t arg) co
+       | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co
+       = Just (co', t:ticks)
+
     ok_arg _ _ _ = Nothing
 
 {-
index acc6c79..59c5214 100644 (file)
@@ -29,6 +29,7 @@ import BasicTypes
 import Util
 import Outputable
 import FastString
+import SrcLoc      ( pprUserRealSpan )
 
 {-
 ************************************************************************
@@ -216,7 +217,10 @@ ppr_expr add_par (Let bind expr)
                 NonRec _ _ -> (sLit "let {")
 
 ppr_expr add_par (Tick tickish expr)
-  = add_par (sep [ppr tickish, pprCoreExpr expr])
+  = sdocWithDynFlags $ \dflags ->
+  if gopt Opt_PprShowTicks dflags
+  then add_par (sep [ppr tickish, pprCoreExpr expr])
+  else ppr_expr add_par expr
 
 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 pprCoreAlt (con, args, rhs)
@@ -490,7 +494,7 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 
 instance Outputable id => Outputable (Tickish id) where
   ppr (HpcTick modl ix) =
-      hcat [ptext (sLit "tick<"),
+      hcat [ptext (sLit "hpc<"),
             ppr modl, comma,
             ppr ix,
             ptext (sLit ">")]
@@ -506,6 +510,8 @@ instance Outputable id => Outputable (Tickish id) where
          (True,True)  -> hcat [ptext (sLit "scctick<"), ppr cc, char '>']
          (True,False) -> hcat [ptext (sLit "tick<"),    ppr cc, char '>']
          _            -> hcat [ptext (sLit "scc<"),     ppr cc, char '>']
+  ppr (SourceNote span _) =
+      hcat [ ptext (sLit "src<"), pprUserRealSpan True span, char '>']
 
 {-
 -----------------------------------------------------
index f57cc9e..b9faf26 100644 (file)
@@ -90,11 +90,12 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
                       , density      = mkDensity dflags
                       , this_mod     = mod
                       , tickishType  = case hscTarget dflags of
-                          HscInterpreted          -> Breakpoints
-                          _ | gopt Opt_Hpc dflags -> HpcTicks
+                          HscInterpreted            -> Breakpoints
+                          _ | gopt Opt_Hpc dflags   -> HpcTicks
                             | gopt Opt_SccProfilingOn dflags
-                                                  -> ProfNotes
-                            | otherwise           -> error "addTicksToBinds: No way to annotate!"
+                                                    -> ProfNotes
+                            | gopt Opt_Debug dflags -> SourceNotes
+                            | otherwise             -> error "addTicksToBinds: No way to annotate!"
                        })
                    (TT
                       { tickBoxCount = 0
@@ -184,13 +185,14 @@ data TickDensity
 
 mkDensity :: DynFlags -> TickDensity
 mkDensity dflags
-  | gopt Opt_Hpc dflags                  = TickForCoverage
+  | gopt Opt_Hpc dflags
+    || gopt Opt_Debug dflags             = TickForCoverage
   | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints
   | ProfAutoAll     <- profAuto dflags   = TickAllFunctions
   | ProfAutoTop     <- profAuto dflags   = TickTopFunctions
   | ProfAutoExports <- profAuto dflags   = TickExportedFunctions
   | ProfAutoCalls   <- profAuto dflags   = TickCallSites
-  | otherwise = panic "desnity"
+  | otherwise                            = panic "density"
   -- ToDo: -fhpc is taking priority over -fprof-auto here.  It seems
   -- that coverage works perfectly well with profiling, but you don't
   -- get any auto-generated SCCs.  It would make perfect sense to
@@ -939,7 +941,7 @@ data TickTransEnv = TTE { fileName     :: FastString
 
 --      deriving Show
 
-data TickishType = ProfNotes | HpcTicks | Breakpoints
+data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
 
 
 -- | Tickishs that only make sense when their source code location
@@ -1113,6 +1115,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
           HpcTicks    -> HpcTick (this_mod env) c
           ProfNotes   -> ProfNote cc count True{-scopes-}
           Breakpoints -> Breakpoint c ids
+          SourceNotes | RealSrcSpan pos' <- pos
+                      -> SourceNote pos' cc_name
+          _otherwise  -> panic "mkTickish: bad source span!"
     in
     ( tickish
     , fvs
index 9f6748b..6d754c6 100644 (file)
@@ -104,6 +104,7 @@ deSugar hsc_env
               target     = hscTarget dflags
               hpcInfo    = emptyHpcInfo other_hpc_info
               want_ticks = gopt Opt_Hpc dflags
+                        || gopt Opt_Debug dflags
                         || target == HscInterpreted
                         || (gopt Opt_SccProfilingOn dflags
                             && case profAuto dflags of
index 6bb3483..d850f66 100644 (file)
@@ -48,6 +48,7 @@ import BasicTypes
 import Outputable
 import FastString
 import Module
+import SrcLoc
 import Fingerprint
 import Binary
 import BooleanFormula ( BooleanFormula )
@@ -426,6 +427,7 @@ data IfaceExpr
 data IfaceTickish
   = IfaceHpcTick Module Int                -- from HpcTick x
   | IfaceSCC     CostCentre Bool Bool      -- from ProfNote
+  | IfaceSource  RealSrcSpan String        -- from SourceNote
   -- no breakpoints: we never export these into interface files
 
 type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
@@ -969,6 +971,8 @@ pprIfaceTickish (IfaceHpcTick m ix)
   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceTickish (IfaceSCC cc tick scope)
   = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
+pprIfaceTickish (IfaceSource src _names)
+  = braces (pprUserRealSpan True src)
 
 ------------------
 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
@@ -1775,6 +1779,14 @@ instance Binary IfaceTickish where
         put_ bh cc
         put_ bh tick
         put_ bh push
+    put_ bh (IfaceSource src name) = do
+        putByte bh 2
+        put_ bh (srcSpanFile src)
+        put_ bh (srcSpanStartLine src)
+        put_ bh (srcSpanStartCol src)
+        put_ bh (srcSpanEndLine src)
+        put_ bh (srcSpanEndCol src)
+        put_ bh name
 
     get bh = do
         h <- getByte bh
@@ -1786,6 +1798,15 @@ instance Binary IfaceTickish where
                     tick <- get bh
                     push <- get bh
                     return (IfaceSCC cc tick push)
+            2 -> do file <- get bh
+                    sl <- get bh
+                    sc <- get bh
+                    el <- get bh
+                    ec <- get bh
+                    let start = mkRealSrcLoc file sl sc
+                        end = mkRealSrcLoc file el ec
+                    name <- get bh
+                    return (IfaceSource (mkRealSrcSpan start end) name)
             _ -> panic ("get IfaceTickish " ++ show h)
 
 instance Binary IfaceConAlt where
index b3321c1..c0a603f 100644 (file)
@@ -1981,6 +1981,7 @@ toIfaceOneShot id | isId id
 toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
 toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
 toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix)
+toIfaceTickish (SourceNote src names)  = Just (IfaceSource src names)
 toIfaceTickish (Breakpoint {})         = Nothing
    -- Ignore breakpoints, since they are relevant only to GHCi, and
    -- should not be serialised (Trac #8333)
index 9864364..96e72df 100644 (file)
@@ -1041,6 +1041,7 @@ tcIfaceApps fun arg
 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
 tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
 tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)
 
 -------------------------
 tcIfaceLit :: Literal -> IfL Literal
index d6b75af..844fa97 100644 (file)
@@ -419,6 +419,7 @@ data GeneralFlag
    | Opt_ErrorSpans -- Include full span info in error messages,
                     -- instead of just the start position.
    | Opt_PprCaseAsLet
+   | Opt_PprShowTicks
 
    -- Suppress all coercions, them replacing with '...'
    | Opt_SuppressCoercions
@@ -455,6 +456,9 @@ data GeneralFlag
    | Opt_DistrustAllPackages
    | Opt_PackageTrust
 
+   -- debugging flags
+   | Opt_Debug
+
    deriving (Eq, Show, Enum)
 
 data WarningFlag =
@@ -887,7 +891,7 @@ data ProfAuto
   | ProfAutoTop        -- ^ top-level functions annotated only
   | ProfAutoExports    -- ^ exported functions annotated only
   | ProfAutoCalls      -- ^ annotate call-sites
-  deriving (Enum)
+  deriving (Eq,Enum)
 
 data Settings = Settings {
   sTargetPlatform        :: Platform,    -- Filled in by SysTools
@@ -2649,6 +2653,9 @@ dynamic_flags = [
   , defFlag "fno-safe-infer"   (noArg (\d -> d { safeInfer = False  } ))
   , defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))
   , defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))
+
+         ------ Debugging flags ----------------------------------------------
+  , defGhcFlag "g"             (NoArg (setGeneralFlag Opt_Debug))
  ]
  ++ map (mkFlag turnOn  ""     setGeneralFlag  ) negatableFlags
  ++ map (mkFlag turnOff "no-"  unSetGeneralFlag) negatableFlags
@@ -2861,6 +2868,7 @@ dFlags = [
 -- See Note [Supporting CLI completion]
 -- Please keep the list of flags below sorted alphabetically
   flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,
+  flagSpec "ppr-ticks"                  Opt_PprShowTicks,
   flagSpec "suppress-coercions"         Opt_SuppressCoercions,
   flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,
   flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,
index c00663b..7b3712d 100644 (file)
@@ -1206,7 +1206,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
-                       corePrepPgm dflags hsc_env core_binds data_tycons ;
+                       corePrepPgm hsc_env location core_binds data_tycons ;
         -----------------  Convert to STG ------------------
         (stg_binds, cost_centre_info)
             <- {-# SCC "CoreToStg" #-}
@@ -1269,7 +1269,7 @@ hscInteractive hsc_env cgguts mod_summary = do
     -- PREPARE FOR CODE GENERATION
     -- Do saturation and convert to A-normal form
     prepd_binds <- {-# SCC "CorePrep" #-}
-                   corePrepPgm dflags hsc_env core_binds data_tycons
+                   corePrepPgm hsc_env location core_binds data_tycons
     -----------------  Generate byte code ------------------
     comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff ---
@@ -1493,7 +1493,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     {- Prepare For Code Generation -}
     -- Do saturation and convert to A-normal form
     prepd_binds <- {-# SCC "CorePrep" #-}
-                    liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
+      liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
 
     {- Generate byte code -}
     cbc <- liftIO $ byteCodeGen dflags this_mod
index 7dbf892..a30c695 100644 (file)
@@ -14,7 +14,8 @@ import CoreSubst
 import Var              ( Var )
 import Id               ( Id, idType, idInlineActivation, zapIdOccInfo )
 import CoreUtils        ( mkAltExpr
-                        , exprIsTrivial)
+                        , exprIsTrivial
+                        , stripTicks, stripTicksTopE, mkTick, mkTicks )
 import Type             ( tyConAppArgs )
 import CoreSyn
 import Outputable
@@ -171,13 +172,13 @@ cseBind env (Rec pairs)
 
 cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
 cseRhs env (id',rhs)
-  = case lookupCSEnv env rhs' of
+  = case lookupCSEnv env rhs'' of
         Nothing
           | always_active -> (extendCSEnv env rhs' id', rhs')
           | otherwise     -> (env,                      rhs')
         Just id
-          | always_active -> (extendCSSubst env id' id, Var id)
-          | otherwise     -> (env,                      Var id)
+          | always_active -> (extendCSSubst env id' id, mkTicks ticks $ Var id)
+          | otherwise     -> (env,                      mkTicks ticks $ Var id)
           -- In the Just case, we have
           --        x = rhs
           --        ...
@@ -189,16 +190,23 @@ cseRhs env (id',rhs)
   where
     rhs' = cseExpr env rhs
 
+    (ticks, rhs'') = stripTicks tickishFloatable rhs'
+    -- We don't want to lose the source notes when a common sub
+    -- expression gets eliminated. Hence we push all (!) of them on
+    -- top of the replaced sub-expression. This is probably not too
+    -- useful in practice, but upholds our semantics.
+
     always_active = isAlwaysActive (idInlineActivation id')
          -- See Note [CSE for INLINE and NOINLINE]
 
 tryForCSE :: CSEnv -> InExpr -> OutExpr
 tryForCSE env expr
-  | exprIsTrivial expr'                   = expr'       -- No point
-  | Just smaller <- lookupCSEnv env expr' = Var smaller
-  | otherwise                             = expr'
+  | exprIsTrivial expr'                    = expr'       -- No point
+  | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks
+  | otherwise                              = expr'
   where
     expr' = cseExpr env expr
+    (ticks, expr'') = stripTicks tickishFloatable expr'
 
 cseExpr :: CSEnv -> InExpr -> OutExpr
 cseExpr env (Type t)               = Type (substTy (csEnvSubst env) t)
@@ -228,8 +236,9 @@ cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
 cseAlts env scrut' bndr bndr' alts
   = map cse_alt alts
   where
+    scrut'' = stripTicksTopE tickishFloatable scrut'
     (con_target, alt_env)
-        = case scrut' of
+        = case scrut'' of
             Var v' -> (v',     extendCSSubst env bndr v')    -- See Note [Case binders 1]
                                                              -- map: bndr -> v'
 
@@ -286,7 +295,8 @@ lookupCSEnv (CS { cs_map = csmap }) expr
 
 extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
 extendCSEnv cse expr id
-  = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,id) }
+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
+  where (_, sexpr) = stripTicks tickishFloatable expr
 
 csEnvSubst :: CSEnv -> Subst
 csEnvSubst = cs_subst
index 3425288..2f1b318 100644 (file)
@@ -20,7 +20,8 @@ module FloatIn ( floatInwards ) where
 
 import CoreSyn
 import MkCore
-import CoreUtils        ( exprIsDupable, exprIsExpandable, exprType, exprOkForSideEffects )
+import CoreUtils        ( exprIsDupable, exprIsExpandable, exprType,
+                          exprOkForSideEffects, mkTicks )
 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
 import Id               ( isOneShotBndr, idType )
 import Var
@@ -151,11 +152,12 @@ pull out any silly ones.
 -}
 
 fiExpr dflags to_drop ann_expr@(_,AnnApp {})
-  = wrapFloats drop_here $ wrapFloats extra_drop $
+  = mkTicks ticks $ wrapFloats drop_here $ wrapFloats extra_drop $
     mkApps (fiExpr dflags fun_drop ann_fun)
            (zipWith (fiExpr dflags) arg_drops ann_args)
   where
-    (ann_fun@(fun_fvs, _), ann_args) = collectAnnArgs ann_expr
+    (ann_fun@(fun_fvs, _), ann_args, ticks)
+           = collectAnnArgsTicks tickishFloatable ann_expr
     fun_ty = exprType (deAnnotate ann_fun)
     ((_,extra_fvs), arg_fvs) = mapAccumL mk_arg_fvs (fun_ty, emptyVarSet) ann_args
 
@@ -244,13 +246,12 @@ We don't float lets inwards past an SCC.
 -}
 
 fiExpr dflags to_drop (_, AnnTick tickish expr)
-  | tickishScoped tickish
-  =     -- Wimp out for now - we could push values in
-    wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
-
-  | otherwise
+  | tickish `tickishScopesLike` SoftScope
   = Tick tickish (fiExpr dflags to_drop expr)
 
+  | otherwise -- Wimp out for now - we could push values in
+  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
+
 {-
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
index 4cd8713..7f7b921 100644 (file)
@@ -280,18 +280,20 @@ floatExpr lam@(Lam (TB _ lam_spec) _)
     (add_to_stats fs floats, floats, mkLams bndrs body') }
 
 floatExpr (Tick tickish expr)
-  | tickishScoped tickish
+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
   = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
-    let
-        -- Annotate bindings floated outwards past an scc expression
+    (fs, floating_defns, Tick tickish expr') }
+
+  | not (tickishCounts tickish) || tickishCanSplit tickish
+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
+    let -- Annotate bindings floated outwards past an scc expression
         -- with the cc.  We mark that cc as "duplicated", though.
         annotated_defns = wrapTick (mkNoCount tickish) floating_defns
     in
     (fs, annotated_defns, Tick tickish expr') }
 
-  | otherwise  -- not scoped, can just float
-  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
-    (fs, floating_defns, Tick tickish expr') }
+  | otherwise
+  = pprPanic "floatExpr tick" (ppr tickish)
 
 floatExpr (Cast expr co)
   = case (floatExpr expr) of { (fs, floating_defns, expr') ->
index 26aec9d..c15026c 100644 (file)
@@ -21,7 +21,8 @@ module OccurAnal (
 
 import CoreSyn
 import CoreFVs
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp,
+                          stripTicksTopE, mkTicks )
 import Id
 import Name( localiseName )
 import BasicTypes
@@ -40,6 +41,7 @@ import Util
 import Outputable
 import FastString
 import Data.List
+import Control.Arrow    ( second )
 
 {-
 ************************************************************************
@@ -1179,18 +1181,19 @@ we can sort them into the right place when doing dependency analysis.
 -}
 
 occAnal env (Tick tickish body)
+  | tickish `tickishScopesLike` SoftScope
+  = (usage, Tick tickish body')
+
   | Breakpoint _ ids <- tickish
-  = (mapVarEnv markInsideSCC usage
-         +++ mkVarEnv (zip ids (repeat NoOccInfo)), Tick tickish body')
+  = (usage_lam +++ mkVarEnv (zip ids (repeat NoOccInfo)), Tick tickish body')
     -- never substitute for any of the Ids in a Breakpoint
 
-  | tickishScoped tickish
-  = (mapVarEnv markInsideSCC usage, Tick tickish body')
-
   | otherwise
-  = (usage, Tick tickish body')
+  = (usage_lam, Tick tickish body')
   where
     !(usage,body') = occAnal env body
+    -- for a non-soft tick scope, we can inline lambdas only
+    usage_lam = mapVarEnv markInsideLam usage
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
@@ -1204,7 +1207,7 @@ occAnal env (Cast expr co)
     }
 
 occAnal env app@(App _ _)
-  = occAnalApp env (collectArgs app)
+  = occAnalApp env (collectArgsTicks tickishFloatable app)
 
 -- Ignore type variables altogether
 --   (a) occurrences inside type lambdas only not marked as InsideLam
@@ -1271,6 +1274,13 @@ occAnal env (Case scrut bndr ty alts)
         = (mkOneOcc env v True, Var v)  -- The 'True' says that the variable occurs
                                         -- in an interesting context; the case has
                                         -- at least one non-default alternative
+    occ_anal_scrut (Tick t e) alts
+        | t `tickishScopesLike` SoftScope
+          -- No reason to not look through all ticks here, but only
+          -- for soft-scoped ticks we can do so without having to
+          -- update returned occurance info (see occAnal)
+        = second (Tick t) $ occ_anal_scrut e alts
+
     occ_anal_scrut scrut _alts
         = occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt
 
@@ -1312,23 +1322,25 @@ Constructors are rather like lambdas in this way.
 -}
 
 occAnalApp :: OccEnv
-           -> (Expr CoreBndr, [Arg CoreBndr])
+           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])
            -> (UsageDetails, Expr CoreBndr)
-occAnalApp env (Var fun, args)
-  = case args_stuff of { (args_uds, args') ->
-    let
-       final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
-          -- We mark the free vars of the argument of a constructor or PAP
-          -- as "many", if it is the RHS of a let(rec).
-          -- This means that nothing gets inlined into a constructor argument
-          -- position, which is what we want.  Typically those constructor
-          -- arguments are just variables, or trivial expressions.
-          --
-          -- This is the *whole point* of the isRhsEnv predicate
-          -- See Note [Arguments of let-bound constructors]
-    in
-    (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
+occAnalApp env (Var fun, args, ticks)
+  | null ticks = (uds, mkApps (Var fun) args')
+  | otherwise  = (uds, mkTicks ticks $ mkApps (Var fun) args')
   where
+    uds = fun_uds +++ final_args_uds
+
+    !(args_uds, args') = occAnalArgs env args one_shots
+    !final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
+       -- We mark the free vars of the argument of a constructor or PAP
+       -- as "many", if it is the RHS of a let(rec).
+       -- This means that nothing gets inlined into a constructor argument
+       -- position, which is what we want.  Typically those constructor
+       -- arguments are just variables, or trivial expressions.
+       --
+       -- This is the *whole point* of the isRhsEnv predicate
+       -- See Note [Arguments of let-bound constructors]
+
     n_val_args = valArgCount args
     fun_uds    = mkOneOcc env fun (n_val_args > 0)
     is_exp     = isExpandableApp fun n_val_args
@@ -1339,26 +1351,17 @@ occAnalApp env (Var fun, args)
     one_shots  = argsOneShots (idStrictness fun) n_val_args
                  -- See Note [Use one-shot info]
 
-    args_stuff = occAnalArgs env args one_shots
-
-                        -- (foldr k z xs) may call k many times, but it never
-                        -- shares a partial application of k; hence [False,True]
-                        -- This means we can optimise
-                        --      foldr (\x -> let v = ...x... in \y -> ...v...) z xs
-                        -- by floating in the v
-
-occAnalApp env (fun, args)
-  = case occAnal (addAppCtxt env args) fun of   { (fun_uds, fun') ->
+occAnalApp env (fun, args, ticks)
+  = (fun_uds +++ args_uds, mkTicks ticks $ mkApps fun' args')
+  where
+    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun
         -- The addAppCtxt is a bit cunning.  One iteration of the simplifier
         -- often leaves behind beta redexs like
         --      (\x y -> e) a1 a2
         -- Here we would like to mark x,y as one-shot, and treat the whole
         -- thing much like a let.  We do this by pushing some True items
         -- onto the context stack.
-
-    case occAnalArgs env args [] of        { (args_uds, args') ->
-    (fun_uds +++ args_uds, mkApps fun' args') }}
-
+    !(args_uds, args') = occAnalArgs env args []
 
 markManyIf :: Bool              -- If this is true
            -> UsageDetails      -- Then do markMany on this
@@ -1731,7 +1734,7 @@ mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
 --                  c) returns a proxy mapping, binding the scrutinee
 --                     to the case binder, if possible
 mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
-  = case scrut of
+  = case stripTicksTopE (const True) scrut of
       Var v           -> add_scrut v case_bndr'
       Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))
                           -- See Note [Case of cast]
@@ -1843,13 +1846,10 @@ mkOneOcc env id int_cxt
   | otherwise
   = emptyDetails
 
-markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
+markMany, markInsideLam :: OccInfo -> OccInfo
 
 markMany _  = NoOccInfo
 
-markInsideSCC occ = markInsideLam occ
-  -- inside an SCC, we can inline lambdas only.
-
 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
 markInsideLam occ                       = occ
 
index e700040..c3ee112 100644 (file)
@@ -592,6 +592,7 @@ notWorthFloating e abs_vars
     go (_, AnnVar {}) n    = n >= 0
     go (_, AnnLit lit) n   = ASSERT( n==0 )
                              litIsTrivial lit   -- Note [Floating literals]
+    go (_, AnnTick t e) n  = not (tickishIsCode t) && go e n
     go (_, AnnCast e _)  n = go e n
     go (_, AnnApp e arg) n
        | (_, AnnType {}) <- arg = go e n
@@ -606,6 +607,7 @@ notWorthFloating e abs_vars
     is_triv (_, AnnCast e _)              = is_triv e
     is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
     is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
+    is_triv (_, AnnTick t e)              = not (tickishIsCode t) && is_triv e
     is_triv _                             = False
 
 {-
index bdb2198..746e0d0 100644 (file)
@@ -20,7 +20,8 @@ import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
 import PprCore          ( pprCoreBindings, pprCoreExpr )
 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
-import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize )
+import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize,
+                          mkTicks, stripTicksTop )
 import CoreLint         ( showPass, endPass, lintPassResult, dumpPassResult )
 import Simplify         ( simplTopBinds, simplExpr )
 import SimplUtils       ( simplEnvForGHCi, activeRule )
@@ -821,9 +822,28 @@ could be eliminated.  But I don't think it's very common
 and it's dangerous to do this fiddling in STG land
 because we might elminate a binding that's mentioned in the
 unfolding for something.
+
+Note [Indirection zapping and ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unfortunately this is another place where we need a special case for
+ticks. The following happens quite regularly:
+
+        x_local = <expression>
+        x_exported = tick<x> x_local
+
+Which we want to become:
+
+        x_exported =  tick<x> <expression>
+
+As it makes no sense to keep the tick and the expression on separate
+bindings. Note however that that this might increase the ticks scoping
+over the execution of x_local, so we can only do this for floatable
+ticks. More often than not, other references will be unfoldings of
+x_exported, and therefore carry the tick anyway.
 -}
 
-type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
+type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks
 
 shortOutIndirections :: CoreProgram -> CoreProgram
 shortOutIndirections binds
@@ -832,8 +852,9 @@ shortOutIndirections binds
   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
   where
     ind_env            = makeIndEnv binds
-    exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
-    exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
+    -- These exported Ids are the subjects  of the indirection-elimination
+    exp_ids            = map fst $ varEnvElts ind_env
+    exp_id_set         = mkVarSet exp_ids
     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
     binds'             = concatMap zap binds
 
@@ -841,10 +862,12 @@ shortOutIndirections binds
     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 
     zapPair (bndr, rhs)
-        | bndr `elemVarSet` exp_id_set             = []
-        | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
-                                                      (bndr, Var exp_id)]
-        | otherwise                                = [(bndr,rhs)]
+        | bndr `elemVarSet` exp_id_set = []
+        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
+                                       = [(transferIdInfo exp_id bndr,
+                                           mkTicks ticks rhs),
+                                          (bndr, Var exp_id)]
+        | otherwise                    = [(bndr,rhs)]
 
 makeIndEnv :: [CoreBind] -> IndEnv
 makeIndEnv binds
@@ -855,8 +878,10 @@ makeIndEnv binds
     add_bind (Rec pairs)              env = foldr add_pair env pairs
 
     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
-    add_pair (exported_id, Var local_id) env
-        | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
+    add_pair (exported_id, exported) env
+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported
+        , shortMeOut env exported_id local_id
+        = extendVarEnv env local_id (exported_id, ticks)
     add_pair _ env = env
 
 -----------------
index a5d8551..96c2fc0 100644 (file)
@@ -31,7 +31,7 @@ module SimplEnv (
 
         -- Floats
         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
-        wrapFloats, setFloats, zapFloats, addRecFloats,
+        wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
         doFloatFromRhs, getFloatBinds
     ) where
 
@@ -486,18 +486,14 @@ isEmptyFloats :: SimplEnv -> Bool
 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
   = isNilOL bs
 
-{-
--- mapFloats commented out: used only in a commented-out bit of Simplify,
--- concerning ticks
---
--- mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
--- mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
---    = env { seFloats = Floats (mapOL app fs) ff }
---    where
---     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
---     app (Rec bs)     = Rec (map fun bs)
-
+mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
+mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
+   = env { seFloats = Floats (mapOL app fs) ff }
+   where
+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
+    app (Rec bs)     = Rec (map fun bs)
 
+{-
 ************************************************************************
 *                                                                      *
                 Substitution of Vars
index 4fd855a..ccc8a56 100644 (file)
@@ -63,6 +63,7 @@ import FastString
 import Pair
 
 import Control.Monad    ( when )
+import Data.List        ( partition )
 
 {-
 ************************************************************************
@@ -961,9 +962,10 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
         -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
         -- so substituting rhs inside a lambda doesn't change the occ info.
         -- Sadly, not quite the same as exprIsHNF.
-    canInlineInLam (Lit _)              = True
-    canInlineInLam (Lam b e)            = isRuntimeVar b || canInlineInLam e
-    canInlineInLam _                    = False
+    canInlineInLam (Lit _)    = True
+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e
+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
+    canInlineInLam _          = False
       -- not ticks.  Counting ticks cannot be duplicated, and non-counting
       -- ticks around a Lam will disappear anyway.
 
@@ -1184,6 +1186,10 @@ mkLam bndrs body cont
       where
         (bndrs1, body1) = collectBinders body
 
+    mkLam' dflags bndrs (Tick t expr)
+      | tickishFloatable t
+      = mkTick t <$> mkLam' dflags bndrs expr
+
     mkLam' dflags bndrs body
       | gopt Opt_DoEtaReduction dflags
       , Just etad_lam <- tryEtaReduce bndrs body
@@ -1643,13 +1649,16 @@ defeats combineIdenticalAlts (see Trac #7360).
 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
 -- See Note [Combine identical alternatives]
 combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
-  | all isDeadBinder bndrs1                     -- Remember the default
-  , length filtered_alts < length con_alts      -- alternative comes first
+  | all isDeadBinder bndrs1    -- Remember the default
+  , not (null eliminated_alts) -- alternative comes first
   = do  { tick (AltMerge case_bndr)
-        ; return ((DEFAULT, [], rhs1) : filtered_alts) }
+        ; return ((DEFAULT, [], mkTicks (concat tickss) rhs1) : filtered_alts) }
   where
-    filtered_alts = filterOut identical_to_alt1 con_alts
-    identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1
+    (eliminated_alts, filtered_alts) = partition identical_to_alt1 con_alts
+    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
+    identical_to_alt1 (_con,bndrs,rhs)
+      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
+    tickss = map (fst . stripTicks tickishFloatable . thirdOf3) eliminated_alts
 
 combineIdenticalAlts _ alts = return alts
 
@@ -1701,7 +1710,8 @@ mkCase, mkCase1, mkCase2
 
 mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
   | gopt Opt_CaseMerge dflags
-  , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)
+       <- stripTicksTop tickishFloatable deflt_rhs
   , inner_scrut_var == outer_bndr
   = do  { tick (CaseMerge outer_bndr)
 
@@ -1725,7 +1735,8 @@ mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
                 -- When we merge, we must ensure that e1 takes
                 -- precedence over e2 as the value for A!
 
-        ; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
+        ; fmap (mkTicks ticks) $
+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts
         }
         -- Warning: don't call mkCase recursively!
         -- Firstly, there's no point, because inner alts have already had
@@ -1742,17 +1753,24 @@ mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
 mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
-       ; return (re_cast scrut rhs1) }
+       ; return (mkTicks ticks $ re_cast scrut rhs1) }
   where
+    ticks = concatMap (fst . stripTicks tickishFloatable . thirdOf3) (tail alts)
     identity_alt (con, args, rhs) = check_eq rhs con args
 
-    check_eq (Cast rhs co) con args         = not (any (`elemVarSet` tyCoVarsOfCo co) args)
-        {- See Note [RHS casts] -}            && check_eq rhs con args
-    check_eq (Lit lit) (LitAlt lit') _      = lit == lit'
-    check_eq (Var v)   _ _ | v == case_bndr = True
-    check_eq (Var v)   (DataAlt con) []     = v == dataConWorkId con   -- Optimisation only
-    check_eq rhs       (DataAlt con) args   = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
-    check_eq _ _ _ = False
+    check_eq (Cast rhs co) con        args
+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args
+        -- See Note [RHS casts]
+    check_eq (Lit lit)  (LitAlt lit') _    = lit == lit'
+    check_eq (Var v) _ _  | v == case_bndr = True
+    check_eq (Var v)    (DataAlt con) []   = v == dataConWorkId con
+                                             -- Optimisation only
+    check_eq (Tick t e) alt           args = tickishFloatable t &&
+                                             check_eq e alt args
+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $
+                                             mkConApp con (arg_tys ++
+                                                           varsToCoreExprs args)
+    check_eq _          _             _    = False
 
     arg_tys = map Type (tyConAppArgs (idType case_bndr))
 
index 18b4c9d..b950f57 100644 (file)
@@ -330,12 +330,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 (tvs, body) = case collectTyBinders rhs of
                                 (tvs, body) | not_lam body -> (tvs,body)
                                             | otherwise    -> ([], rhs)
-                not_lam (Lam _ _) = False
-                not_lam _         = True
+                not_lam (Lam _ _)  = False
+                not_lam (Tick t e) | not (tickishFloatable t)
+                                   = not_lam e -- eta-reduction could float
+                not_lam _          = True
                         -- Do not do the "abstract tyyvar" thing if there's
                         -- a lambda inside, because it defeats eta-reduction
                         --    f = /\a. \x. g a x
-                        -- should eta-reduce
+                        -- should eta-reduce.
 
 
         ; (body_env, tvs') <- simplBinders rhs_env tvs
@@ -486,6 +488,21 @@ prepareRhs top_lvl env0 _ rhs0
                         -- The definition of is_exp should match that in
                         -- OccurAnal.occAnalApp
 
+    go n_val_args env (Tick t rhs)
+        -- We want to be able to float bindings past this
+        -- tick. Non-scoping ticks don't care.
+        | tickishScoped t == NoScope
+        = do { (is_exp, env', rhs') <- go n_val_args env rhs
+             ; return (is_exp, env', Tick t rhs') }
+        -- On the other hand, for scoping ticks we need to be able to
+        -- copy them on the floats, which in turn is only allowed if
+        -- we can obtain non-counting ticks.
+        | not (tickishCounts t) || tickishCanSplit t
+        = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs
+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+                   floats' = seFloats $ env `addFloats` mapFloats env' tickIt
+             ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }
+
     go _ env other
         = return (False, env, other)
 
@@ -1019,58 +1036,48 @@ simplTick env tickish expr cont
 --  | tickishScoped tickish && not (tickishCounts tickish)
 --  = simplExprF env expr (TickIt tickish cont)
 
-  -- For non-scoped ticks, we push the continuation inside the
-  -- tick.  This has the effect of moving the tick to the outside of a
-  -- case or application context, allowing the normal case and
-  -- application optimisations to fire.
-  | not (tickishScoped tickish)
+  -- For unscoped or soft-scoped ticks, we are allowed to float in new
+  -- cost, so we simply push the continuation inside the tick.  This
+  -- has the effect of moving the tick to the outside of a case or
+  -- application context, allowing the normal case and application
+  -- optimisations to fire.
+  | tickish `tickishScopesLike` SoftScope
   = do { (env', expr') <- simplExprF env expr cont
        ; return (env', mkTick tickish expr')
        }
 
-  -- For breakpoints, we cannot do any floating of bindings around the
-  -- tick, because breakpoints cannot be split into tick/scope pairs.
-  | not (tickishCanSplit tickish)
-  = no_floating_past_tick
-
-  | interesting_cont, Just expr' <- push_tick_inside tickish expr
-    -- see Note [case-of-scc-of-case]
+  -- Push tick inside if the context looks like this will allow us to
+  -- do a case-of-case - see Note [case-of-scc-of-case]
+  | Select {} <- cont, Just expr' <- push_tick_inside
   = simplExprF env expr' cont
 
+  -- We don't want to move the tick, but we might still want to allow
+  -- floats to pass through with appropriate wrapping (or not, see
+  -- wrap_floats below)
+  --- | not (tickishCounts tickish) || tickishCanSplit tickish
+  -- = wrap_floats
+
   | otherwise
-  = no_floating_past_tick -- was: wrap_floats, see below
+  = no_floating_past_tick
 
  where
-  interesting_cont = case cont of
-                        Select {} -> True
-                        _ -> False
-
-  push_tick_inside t expr0
-       = ASSERT(tickishScoped t)
-         case expr0 of
-           Tick t' expr
-              -- scc t (tick t' E)
-              --   Pull the tick to the outside
-              -- This one is important for #5363
-              | not (tickishScoped t')
-                 -> Just (Tick t' (Tick t expr))
-
-              -- scc t (scc t' E)
-              --   Try to push t' into E first, and if that works,
-              --   try to push t in again
-              | Just expr' <- push_tick_inside t' expr
-                 -> push_tick_inside t expr'
-
-              | otherwise -> Nothing
-
-           Case scrut bndr ty alts
-              | not (tickishCanSplit t) -> Nothing
-              | otherwise -> Just (Case (mkTick t scrut) bndr ty alts')
-             where t_scope = mkNoCount t -- drop the tick on the dup'd ones
-                   alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
-
-           _other -> Nothing
-    where
+
+  -- Try to push tick inside a case, see Note [case-of-scc-of-case].
+  push_tick_inside =
+    case expr0 of
+      Case scrut bndr ty alts
+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)
+      _other -> Nothing
+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
+         movable t      = not (tickishCounts t) ||
+                          t `tickishScopesLike` NoScope ||
+                          tickishCanSplit t
+         tickScrut e    = foldr mkTick e ticks
+         -- Alternatives get annotated with all ticks that scope in some way,
+         -- but we don't want to count entries.
+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)
+         ts_scope         = map mkNoCount $
+                            filter (not . (`tickishScopesLike` NoScope)) ticks
 
   no_floating_past_tick =
     do { let (inc,outc) = splitCont cont
index a768896..b66d973 100644 (file)
@@ -35,7 +35,8 @@ import CoreSyn          -- All of it
 import CoreSubst
 import OccurAnal        ( occurAnalyseExpr )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
-import CoreUtils        ( exprType, eqExpr )
+import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
+                          stripTicksTopT, stripTicksTopE )
 import PprCore          ( pprRules )
 import Type             ( Type )
 import TcType           ( tcSplitTyConApp_maybe )
@@ -194,6 +195,8 @@ roughTopName (App f _) = roughTopName f
 roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]
                        , isDataConWorkId f || idArity f > 0
                        = Just (idName f)
+roughTopName (Tick t e) | tickishFloatable t
+                        = roughTopName e
 roughTopName _ = Nothing
 
 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
@@ -361,20 +364,28 @@ lookupRule dflags in_scope is_active fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
         []     -> Nothing
-        (m:ms) -> Just (findBest (fn,args) m ms)
+        (m:ms) -> Just (findBest (fn,args') m ms)
   where
     rough_args = map roughTopName args
 
+    -- Strip ticks from arguments, see note [Tick annotations in RULE
+    -- matching]. We only collect ticks if a rule actually matches -
+    -- this matters for performance tests.
+    args' = map (stripTicksTopE tickishFloatable) args
+    ticks = concatMap (stripTicksTopT tickishFloatable) args
+
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
-    go ms []           = ms
-    go ms (r:rs) = case (matchRule dflags in_scope is_active fn args rough_args r) of
-                        Just e  -> go ((r,e):ms) rs
-                        Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
-                                   --   ppr [ (arg_id, unfoldingTemplate unf)
-                                   --       | Var arg_id <- args
-                                   --       , let unf = idUnfolding arg_id
-                                   --       , isCheapUnfolding unf] )
-                                   go ms rs
+    go ms [] = ms
+    go ms (r:rs)
+      | Just e <- matchRule dflags in_scope is_active fn args' rough_args r
+      = go ((r,mkTicks ticks e):ms) rs
+      | otherwise
+      = -- pprTrace "match failed" (ppr r $$ ppr args $$
+        --   ppr [ (arg_id, unfoldingTemplate unf)
+        --       | Var arg_id <- args
+        --       , let unf = idUnfolding arg_id
+        --       , isCheapUnfolding unf] )
+        go ms rs
 
 findBest :: (Id, [CoreExpr])
          -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
@@ -609,6 +620,14 @@ match :: RuleMatchEnv
       -> CoreExpr               -- Target
       -> Maybe RuleSubst
 
+-- We look through certain ticks. See note [Tick annotations in RULE matching]
+match renv subst e1 (Tick t e2)
+  | tickishFloatable t
+  = match renv subst' e1 e2
+  where subst' = subst { rs_binds = rs_binds subst . mkTick t }
+match _ _ e@Tick{} _
+  = pprPanic "Tick in rule" (ppr e)
+
 -- See the notes with Unify.match, which matches types
 -- Everything is very similar for terms
 
@@ -675,10 +694,11 @@ match renv subst (App f1 a1) (App f2 a2)
         ; match renv subst' a1 a2 }
 
 match renv subst (Lam x1 e1) e2
-  | Just (x2, e2) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
+  | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
   = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
                      , rv_fltR = delBndr (rv_fltR renv) x2 }
-    in  match renv' subst e1 e2
+        subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }
+    in  match renv' subst' e1 e2
 
 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
   = do  { subst1 <- match_ty renv subst ty1 ty2
@@ -890,10 +910,17 @@ Hence, (a) the guard (not (isLocallyBoundR v2))
 
 Note [Tick annotations in RULE matching]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to look through Notes in both template and expression being
-matched.  This would be incorrect for ticks, which we cannot discard,
-so we do not look through Ticks at all.  cf Note [Notes in call
-patterns] in SpecConstr
+
+We used to unconditionally look through Notes in both template and
+expression being matched. This is actually illegal for counting or
+cost-centre-scoped ticks, because we have no place to put them without
+changing entry counts and/or costs. So now we just fail the match in
+these cases.
+
+On the other hand, where we are allowed to insert new cost into the
+tick scope, we can float them upwards to the rule application site.
+
+cf Note [Notes in call patterns] in SpecConstr
 
 Note [Matching lets]
 ~~~~~~~~~~~~~~~~~~~~
index 11ba67e..9b24604 100644 (file)
@@ -886,7 +886,8 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
    = (env2, alt_bndrs')
  where
    live_case_bndr = not (isDeadBinder case_bndr)
-   env1 | Var v <- scrut = extendValEnv env v cval
+   env1 | Var v <- stripTicksTopE (const True) scrut
+                         = extendValEnv env v cval
         | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]
    env2 | live_case_bndr = extendValEnv env1 case_bndr cval
         | otherwise      = env1
@@ -1974,8 +1975,12 @@ isValue env (Lam b e)
                   Nothing -> Nothing
   | otherwise = Just LambdaVal
 
+isValue env (Tick t e)
+  | not (tickishIsCode t)
+  = isValue env e
+
 isValue _env expr       -- Maybe it's a constructor application
-  | (Var fun, args) <- collectArgs expr
+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr
   = case isDataConWorkId_maybe fun of
 
         Just con | args `lengthAtLeast` dataConRepArity con
index 5b22e67..55a31d4 100644 (file)
@@ -398,6 +398,9 @@ coreToStgExpr (Tick (ProfNote cc tick push) expr)
 coreToStgExpr (Tick Breakpoint{} _expr)
   = panic "coreToStgExpr: breakpoint should not happen"
 
+coreToStgExpr (Tick _ expr)
+  = {- dropped for now ... -} coreToStgExpr expr
+
 coreToStgExpr (Cast expr _)
   = coreToStgExpr expr
 
index ad72ca1..9e735e7 100644 (file)
@@ -9,6 +9,7 @@ Provide trees (of instructions), so that lists of instructions
 can be appended in linear time.
 -}
 
+{-# LANGUAGE CPP #-}
 module OrdList (
         OrdList,
         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL,
@@ -17,6 +18,10 @@ module OrdList (
 
 import Outputable
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Monoid ( Monoid(..) )
+#endif
+
 infixl 5  `appOL`
 infixl 5  `snocOL`
 infixr 5  `consOL`
@@ -33,6 +38,11 @@ data OrdList a
 instance Outputable a => Outputable (OrdList a) where
   ppr ol = ppr (fromOL ol)  -- Convert to list and print that
 
+instance Monoid (OrdList a) where
+  mempty = nilOL
+  mappend = appOL
+  mconcat = concatOL
+
 nilOL    :: OrdList a
 isNilOL  :: OrdList a -> Bool