diff options
29 files changed, 873 insertions, 322 deletions
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 8e17561651..03e415b816 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -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) diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 5128891763..07ef3980c7 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -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 -------------- diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index af475bab3f..cce313df4b 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -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 diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 62efae2919..f1bdd73a59 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -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') } diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 82e18ca5ba..b381dc8db7 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 0c6ee7c38e..1a1f8404cc 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -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 diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index dc9f95e73a..1dbd5edd7a 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -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 diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index ffb327523c..c5340b867b 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -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 {- diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index acc6c79fa1..59c5214581 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -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 '>'] {- ----------------------------------------------------- diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index f57cc9e9f6..b9faf26e93 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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 diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 9f6748b882..6d754c6d0b 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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 diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 6bb34838c5..d850f66de1 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -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 diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index b3321c19de..c0a603fb98 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 9864364b89..96e72df502 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d6b75afecc..844fa97e35 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index c00663b6ab..7b3712de78 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 7dbf892f9e..a30c695181 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -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 diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index 34252881ab..2f1b31874e 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -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, diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 4cd871334d..7f7b921fa8 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -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') -> diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 26aec9dcc7..c15026c539 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -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 diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index e7000409e7..c3ee112de4 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -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 {- diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index bdb21987b8..746e0d0724 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -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 ----------------- diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index a5d8551a3a..96c2fc046d 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -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 diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 4fd855a828..ccc8a56cc0 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -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)) diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 18b4c9dee3..b950f570b8 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -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 diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index a768896763..b66d973248 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 11ba67e8d2..9b24604404 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -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 diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 5b22e67eaf..55a31d4255 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -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 diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs index ad72ca1d45..9e735e7d80 100644 --- a/compiler/utils/OrdList.hs +++ b/compiler/utils/OrdList.hs @@ -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 |