Commit 993975d3 authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

Source notes (Core support)

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)
parent 1b5d7583
......@@ -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)
......
......@@ -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
--------------
......
......@@ -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
......
......@@ -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') }
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
This diff is collapsed.
......@@ -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 '>']
{-
-----------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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') ->
......
......@@ -21,7 +21,8 @@ module OccurAnal (