summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Coverage.lhs556
-rw-r--r--compiler/deSugar/Desugar.lhs35
-rw-r--r--compiler/deSugar/DsArrows.lhs5
-rw-r--r--compiler/deSugar/DsBinds.lhs146
-rw-r--r--compiler/deSugar/DsExpr.lhs13
-rw-r--r--compiler/deSugar/DsGRHSs.lhs11
-rw-r--r--compiler/deSugar/DsUtils.lhs71
-rw-r--r--compiler/deSugar/Match.lhs2
8 files changed, 472 insertions, 367 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index abb8948de6..117e1deb3b 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -2,11 +2,10 @@
% (c) Galois, 2006
% (c) University of Glasgow, 2007
%
-\section[Coverage]{@coverage@: the main function}
-
\begin{code}
-module Coverage (addCoverageTicksToBinds, hpcInitCode) where
+module Coverage (addTicksToBinds, hpcInitCode) where
+import Type
import HsSyn
import Module
import Outputable
@@ -14,8 +13,11 @@ import DynFlags
import Control.Monad
import SrcLoc
import ErrUtils
+import NameSet hiding (FreeVars)
import Name
import Bag
+import CostCentre
+import CoreSyn
import Id
import VarSet
import Data.List
@@ -24,6 +26,7 @@ import HscTypes
import Platform
import StaticFlags
import TyCon
+import BasicTypes
import MonadUtils
import Maybes
import CLabel
@@ -44,174 +47,306 @@ import qualified Data.Map as Map
%************************************************************************
%* *
-%* The main function: addCoverageTicksToBinds
+%* The main function: addTicksToBinds
%* *
%************************************************************************
\begin{code}
-addCoverageTicksToBinds
+addTicksToBinds
:: DynFlags
-> Module
- -> ModLocation -- of the current module
- -> [TyCon] -- type constructor in this module
+ -> ModLocation -- ... off the current module
+ -> NameSet -- Exported Ids. When we call addTicksToBinds,
+ -- isExportedId doesn't work yet (the desugarer
+ -- hasn't set it), so we have to work from this set.
+ -> [TyCon] -- Type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
-addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
- case ml_hs_file mod_loc of
- Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
- Just orig_file -> do
-
- if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
-
- -- Now, we try look for a file generated from a .hsc file to a .hs file, by peeking ahead.
+addTicksToBinds dflags mod mod_loc exports tyCons binds =
- let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds
- let orig_file2 = case top_pos of
- (file_name:_)
- | ".hsc" `isSuffixOf` unpackFS file_name -> unpackFS file_name
- _ -> orig_file
+ case ml_hs_file mod_loc of
+ Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
+ Just orig_file -> do
- let mod_name = moduleNameString (moduleName mod)
+ if "boot" `isSuffixOf` orig_file
+ then return (binds, emptyHpcInfo False, emptyModBreaks)
+ else do
+
+ let orig_file2 = guessSourceFile binds orig_file
- let (binds1,_,st)
+ (binds1,_,st)
= unTM (addTickLHsBinds binds)
(TTE
- { fileName = mkFastString orig_file2
+ { fileName = mkFastString orig_file2
, declPath = []
+ , dflags = dflags
+ , exports = exports
, inScope = emptyVarSet
- , blackList = Map.fromList [ (getSrcSpan (tyConName tyCon),())
- | tyCon <- tyCons ]
- })
+ , blackList = Map.fromList
+ [ (getSrcSpan (tyConName tyCon),())
+ | tyCon <- tyCons ]
+ , density = mkDensity dflags
+ , this_mod = mod
+ })
(TT
{ tickBoxCount = 0
, mixEntries = []
})
- let entries = reverse $ mixEntries st
-
- -- write the mix entries for this module
- hashNo <- if opt_Hpc then do
- let hpc_dir = hpcDir dflags
-
- let hpc_mod_dir = if modulePackageId mod == mainPackageId
- then hpc_dir
- else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
-
- let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
- createDirectoryIfMissing True hpc_mod_dir
- modTime <- getModificationTime orig_file2
- let entries' = [ (hpcPos, box)
- | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
- when (length entries' /= tickBoxCount st) $ do
- panic "the number of .mix entries are inconsistent"
- let hashNo = mixHash orig_file2 modTime tabStop entries'
- mixCreate hpc_mod_dir mod_name
- $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
- return $ hashNo
- else do
- return $ 0
-
- -- Todo: use proper src span type
- breakArray <- newBreakArray $ length entries
+ let entries = reverse $ mixEntries st
- let locsTicks = listArray (0,tickBoxCount st-1)
- [ span | (span,_,_,_) <- entries ]
- varsTicks = listArray (0,tickBoxCount st-1)
- [ vars | (_,_,vars,_) <- entries ]
- declsTicks= listArray (0,tickBoxCount st-1)
- [ decls | (_,decls,_,_) <- entries ]
- modBreaks = emptyModBreaks
- { modBreaks_flags = breakArray
- , modBreaks_locs = locsTicks
- , modBreaks_vars = varsTicks
- , modBreaks_decls = declsTicks
- }
-
- doIfSet_dyn dflags Opt_D_dump_hpc $ do
- printDump (pprLHsBinds binds1)
-
- return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
-\end{code}
+ let count = tickBoxCount st
+ hashNo <- writeMixEntries dflags mod count entries orig_file2
+ modBreaks <- mkModBreaks count entries
+ doIfSet_dyn dflags Opt_D_dump_ticked $ printDump (pprLHsBinds binds1)
+
+ return (binds1, HpcInfo count hashNo, modBreaks)
-\begin{code}
-liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
-liftL f (L loc a) = do
- a' <- f a
- return $ L loc a'
+
+guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
+guessSourceFile binds orig_file =
+ -- Try look for a file generated from a .hsc file to a
+ -- .hs file, by peeking ahead.
+ let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
+ srcSpanFileName_maybe pos : rest) [] binds
+ in
+ case top_pos of
+ (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
+ -> unpackFS file_name
+ _ -> orig_file
+
+
+mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks count entries = do
+ breakArray <- newBreakArray $ length entries
+ let
+ locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
+ varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
+ declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
+ modBreaks = emptyModBreaks
+ { modBreaks_flags = breakArray
+ , modBreaks_locs = locsTicks
+ , modBreaks_vars = varsTicks
+ , modBreaks_decls = declsTicks
+ }
+ --
+ return modBreaks
+
+
+writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
+writeMixEntries dflags mod count entries filename
+ | not opt_Hpc = return 0
+ | otherwise = do
+ let
+ hpc_dir = hpcDir dflags
+ mod_name = moduleNameString (moduleName mod)
+
+ hpc_mod_dir
+ | modulePackageId mod == mainPackageId = hpc_dir
+ | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
+
+ tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
+
+ createDirectoryIfMissing True hpc_mod_dir
+ modTime <- getModificationTime filename
+ let entries' = [ (hpcPos, box)
+ | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+ when (length entries' /= count) $ do
+ panic "the number of .mix entries are inconsistent"
+ let hashNo = mixHash filename modTime tabStop entries'
+ mixCreate hpc_mod_dir mod_name
+ $ Mix filename modTime (toHash hashNo) tabStop entries'
+ return hashNo
+
+
+-- -----------------------------------------------------------------------------
+-- TickDensity: where to insert ticks
+
+data TickDensity
+ = TickForCoverage -- for Hpc
+ | TickForBreakPoints -- for GHCi
+ | TickAllFunctions -- for -prof-auto-all
+ | TickTopFunctions -- for -prof-auto-top
+ | TickExportedFunctions -- for -prof-auto-exported
+ -- maybe also:
+ -- | TickCallSites -- for stack tracing
+ deriving Eq
+
+mkDensity :: DynFlags -> TickDensity
+mkDensity dflags
+ | opt_Hpc = TickForCoverage
+ | HscInterpreted <- hscTarget dflags = TickForBreakPoints
+ | ProfAutoAll <- profAuto dflags = TickAllFunctions
+ | ProfAutoTop <- profAuto dflags = TickTopFunctions
+ | ProfAutoExports <- profAuto dflags = TickExportedFunctions
+ | otherwise = panic "desnity"
+
+
+-- | Decide whether to add a tick to a binding or not.
+shouldTickBind :: TickDensity
+ -> Bool -- top level?
+ -> Bool -- exported?
+ -> Bool -- simple pat bind?
+ -> Bool -- INLINE pragma?
+ -> Bool
+
+shouldTickBind density top_lev exported simple_pat inline
+ = case density of
+ TickForBreakPoints -> not simple_pat
+ -- we never add breakpoints to simple pattern bindings
+ -- (there's always a tick on the rhs anyway).
+ TickAllFunctions -> not inline
+ TickTopFunctions -> top_lev && not inline
+ TickExportedFunctions -> exported && not inline
+ TickForCoverage -> True
+
+shouldTickPatBind :: TickDensity -> Bool -> Bool
+shouldTickPatBind density top_lev
+ = case density of
+ TickForBreakPoints -> False
+ TickAllFunctions -> True
+ TickTopFunctions -> top_lev
+ TickExportedFunctions -> False
+ TickForCoverage -> False
+
+-- -----------------------------------------------------------------------------
+-- Adding ticks to bindings
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTickLHsBind binds
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
+ abs_exports = abs_exports })) = do
+ withEnv add_exports $ do
binds' <- addTickLHsBinds binds
return $ L pos $ bind { abs_binds = binds' }
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
+ where
+ -- in AbsBinds, the Id on each binding is not the actual top-level
+ -- Id that we are defining, they are related by the abs_exports
+ -- field of AbsBinds. So if we're doing TickExportedFunctions we need
+ -- to add the local Ids to the set of exported Names so that we know to
+ -- tick the right bindings.
+ add_exports env =
+ env{ exports = exports env `addListToNameSet`
+ [ idName mid
+ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+ , idName pid `elemNameSet` (exports env) ] }
+
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
(fvs, (MatchGroup matches' ty)) <-
getFreeVars $
addPathEntry name $
- addTickMatchGroup (fun_matches funBind)
+ addTickMatchGroup False (fun_matches funBind)
blackListed <- isBlackListed pos
+ density <- getDensity
+ exported_names <- liftM exports getEnv
- -- Todo: we don't want redundant ticks on simple pattern bindings
-- We don't want to generate code for blacklisted positions
- if blackListed || (not opt_Hpc && isSimplePatBind funBind)
- then
- return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
- , fun_tick = Nothing
- }
- else do
- tick_no <- allocATickBox (if null decl_path
- then TopLevelBox [name]
- else LocalBox (decl_path ++ [name]))
- pos fvs
-
- return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
- , fun_tick = tick_no
- }
+ -- We don't want redundant ticks on simple pattern bindings
+ -- We don't want to tick non-exported bindings in TickExportedFunctions
+ let simple = isSimplePatBind funBind
+ toplev = null decl_path
+ exported = idName id `elemNameSet` exported_names
+ inline = pprTrace "inline" (ppr id <+> ppr (idInlinePragma id)) $ isAnyInlinePragma (idInlinePragma id)
+
+ tick <- if not blackListed &&
+ shouldTickBind density toplev exported simple inline
+ then
+ bindTick density name pos fvs
+ else
+ return Nothing
+
+ return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
+ , fun_tick = tick }
+
where
-- a binding is a simple pattern binding if it is a funbind with zero patterns
isSimplePatBind :: HsBind a -> Bool
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-- TODO: Revisit this
-addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
let name = "(...)"
- rhs' <- addPathEntry name $ addTickGRHSs False rhs
-{-
+ (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+
+ density <- getDensity
decl_path <- getPathEntry
- tick_me <- allocTickBox (if null decl_path
- then TopLevelBox [name]
- else LocalBox (name : decl_path))
--}
- return $ L pos $ pat { pat_rhs = rhs' }
+ let top_lev = null decl_path
+ let add_ticks = shouldTickPatBind density top_lev
+
+ tickish <- if add_ticks
+ then bindTick density name pos fvs
+ else return Nothing
+
+ let patvars = map getOccString (collectPatBinders lhs)
+ patvar_ticks <- if add_ticks
+ then mapM (\v -> bindTick density v pos fvs) patvars
+ else return []
+
+ return $ L pos $ pat { pat_rhs = rhs',
+ pat_ticks = (tickish, patvar_ticks)}
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+
+bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick density name pos fvs = do
+ decl_path <- getPathEntry
+ let
+ toplev = null decl_path
+ count_entries = toplev || density == TickAllFunctions
+ top_only = density /= TickAllFunctions
+ box_label = if toplev then TopLevelBox [name]
+ else LocalBox (decl_path ++ [name])
+ --
+ allocATickBox box_label count_entries top_only pos fvs
+
+
+-- -----------------------------------------------------------------------------
+-- Decorate an LHsExpr with ticks
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr (L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForCoverage -> tick_it
+ TickForBreakPoints -> if isGoodBreakExpr e0 then tick_it else dont_tick_it
+ _other -> dont_tick_it
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1
+
-- Add a tick to the expression no matter what it is. There is one exception:
-- for the debugger, if the expression is a 'let', then we don't want to add
-- a tick here because there will definititely be a tick on the body anyway.
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprAlways (L pos e0)
- | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
- | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
-
-addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprNeverOrAlways e
- | opt_Hpc = addTickLHsExprNever e
- | otherwise = addTickLHsExprAlways e
-
-addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprNeverOrMaybe e
- | opt_Hpc = addTickLHsExprNever e
- | otherwise = addTickLHsExpr e
+addTickLHsExprAlways (L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForBreakPoints | HsLet _ _ <- e0 -> dont_tick_it
+ | otherwise -> tick_it
+ TickForCoverage -> tick_it
+ _other -> dont_tick_it
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1
+
+-- | A let body is ticked only if we're doing breakpoints. For coverage, the
+-- whole let is ticked, so there's no need to tick the body.
+addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprLetBody e
+ = ifDensity TickForBreakPoints
+ (addTickLHsExprAlways e)
+ (addTickLHsExprNever e)
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
@@ -221,16 +356,6 @@ addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
--- selectively add ticks to interesting expressions
-addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExpr (L pos e0) = do
- if opt_Hpc || isGoodBreakExpr e0
- then do
- allocTickBox (ExpBox False) pos $ addTickHsExpr e0
- else do
- e1 <- addTickHsExpr e0
- return $ L pos e1
-
-- general heuristic: expressions which do not denote values are good break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {}) = True
@@ -246,15 +371,19 @@ isGoodBreakExpr _other = False
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprOptAlt oneOfMany (L pos e0)
- | not opt_Hpc = addTickLHsExpr (L pos e0)
- | otherwise =
- allocTickBox (ExpBox oneOfMany) pos $
- addTickHsExpr e0
+ = ifDensity TickForCoverage
+ (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
+ (addTickLHsExpr (L pos e0))
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
-addBinTickLHsExpr boxLabel (L pos e0) =
- allocBinTickBox boxLabel pos $
- addTickHsExpr e0
+addBinTickLHsExpr boxLabel (L pos e0)
+ = ifDensity TickForCoverage
+ (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
+ (addTickLHsExpr (L pos e0))
+
+
+-- -----------------------------------------------------------------------------
+-- Decoarate an HsExpr with ticks
addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
addTickHsExpr e@(HsVar id) = do freeVar id; return e
@@ -262,20 +391,23 @@ addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) =
- liftM HsLam (addTickMatchGroup matchgroup)
-addTickHsExpr (HsApp e1 e2) =
+ liftM HsLam (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsApp e1 e2) =
liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsExpr (OpApp e1 e2 fix e3) =
liftM4 OpApp
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
(return fix)
- (addTickLHsExpr e3)
+ (addTickLHsExpr e3)
addTickHsExpr (NegApp e neg) =
liftM2 NegApp
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNeverOrMaybe e)
+addTickHsExpr (HsPar e) =
+ liftM HsPar $
+ ifDensity TickForCoverage (addTickLHsExprNever e)
+ (addTickLHsExpr e)
addTickHsExpr (SectionL e1 e2) =
liftM2 SectionL
(addTickLHsExpr e1)
@@ -291,7 +423,7 @@ addTickHsExpr (ExplicitTuple es boxity) =
addTickHsExpr (HsCase e mgs) =
liftM2 HsCase
(addTickLHsExpr e)
- (addTickMatchGroup mgs)
+ (addTickMatchGroup False mgs)
addTickHsExpr (HsIf cnd e1 e2 e3) =
liftM3 (HsIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
@@ -301,7 +433,7 @@ addTickHsExpr (HsLet binds e) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
- (addTickLHsExprNeverOrAlways e)
+ (addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt stmts' srcloc) }
@@ -338,7 +470,7 @@ addTickHsExpr (ArithSeq ty arith_seq) =
(return ty)
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
- e2 <- allocTickBox (ExpBox False) pos $
+ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
addTickHsExpr (PArrSeq ty arith_seq) =
@@ -374,34 +506,48 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
-addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
-addTickMatchGroup (MatchGroup matches ty) = do
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
+addTickMatchGroup is_lam (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
- matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
+ matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ MatchGroup matches' ty
-addTickMatch :: Bool -> Match Id -> TM (Match Id)
-addTickMatch isOneOfMany (Match pats opSig gRHSs) =
+addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
+addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
- gRHSs' <- addTickGRHSs isOneOfMany gRHSs
+ gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match pats opSig gRHSs'
-addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
-addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
+addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
+addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
- guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
+ guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
return $ GRHSs guarded' local_binds'
where
binders = collectLocalBinders local_binds
-addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
-addTickGRHS isOneOfMany (GRHS stmts expr) = do
+addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
+addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
- (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
- else addTickLHsExprAlways expr)
+ (addTickGRHSBody isOneOfMany isLambda expr)
return $ GRHS stmts' expr'
+addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
+ TickAllFunctions | isLambda ->
+ addPathEntry "\\" $
+ allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
+ addTickHsExpr e0
+ TickTopFunctions ->
+ allocTickBox (ExpBox False) False{-no count-} True{-top-} pos $
+ addTickHsExpr e0
+ _otherwise ->
+ addTickLHsExprAlways expr
+
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
@@ -673,6 +819,11 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(addTickLHsExpr e3)
+
+liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
+liftL f (L loc a) = do
+ a' <- f a
+ return $ L loc a'
\end{code}
\begin{code}
@@ -680,11 +831,15 @@ data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry_]
}
-data TickTransEnv = TTE { fileName :: FastString
- , declPath :: [String]
+data TickTransEnv = TTE { fileName :: FastString
+ , density :: TickDensity
+ , dflags :: DynFlags
+ , exports :: NameSet
+ , declPath :: [String]
, inScope :: VarSet
- , blackList :: Map SrcSpan ()
- }
+ , blackList :: Map SrcSpan ()
+ , this_mod :: Module
+ }
-- deriving Show
@@ -731,6 +886,12 @@ withEnv f (TM m) = TM $ \ env st ->
case m (f env) st of
(a, fvs, st') -> (a, fvs, st')
+getDensity :: TM TickDensity
+getDensity = TM $ \env st -> (density env, noFVs, st)
+
+ifDensity :: TickDensity -> TM a -> TM a -> TM a
+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
+
getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars (TM m)
= TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
@@ -773,46 +934,73 @@ isBlackListed pos = TM $ \ env st ->
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
-allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
-allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
- sameFileName pos
- (do e <- m; return (L pos e)) $ do
- (fvs, e) <- getFreeVars m
+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
+ -> TM (LHsExpr Id)
+allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
+ sameFileName pos (do e <- m; return (L pos e)) $ do
+ (fvs, e) <- getFreeVars m
+ env <- getEnv
+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
+ return (L pos (HsTick tickish (L pos e)))
+allocTickBox _boxLabel _countEntries _topOnly pos m = do
+ e <- m
+ return (L pos e)
+
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
+ -> TM (Maybe (Tickish Id))
+allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos =
+ sameFileName pos (return Nothing) $ do
+ let
+ mydecl_path = case boxLabel of
+ TopLevelBox x -> x
+ LocalBox xs -> xs
+ _ -> panic "allocATickBox"
+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
+ return (Just tickish)
+allocATickBox _boxLabel _countEntries _topOnly _pos _fvs =
+ return Nothing
+
+
+mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
+ -> TM (Tickish Id)
+mkTickish boxLabel countEntries topOnly pos fvs decl_path =
TM $ \ env st ->
let c = tickBoxCount st
- ids = occEnvElts fvs
+ ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs
+ -- unlifted types cause two problems here:
+ -- * we can't bind them at the GHCi prompt
+ -- (bindLocalsAtBreakpoint already fliters them out),
+ -- * the simplifier might try to substitute a literal for
+ -- the Id, and we can't handle that.
+
mes = mixEntries st
- me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
+ me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
+
+ cc_name | topOnly = head decl_path
+ | otherwise = concat (intersperse "." decl_path)
+
+ cc = mkUserCC (mkFastString cc_name) (this_mod env)
+
+ count = countEntries && dopt Opt_ProfCountEntries (dflags env)
+
+ tickish
+ | opt_Hpc = HpcTick (this_mod env) c
+ | opt_SccProfilingOn = ProfNote cc count True{-scopes-}
+ | otherwise = Breakpoint c ids
in
- ( L pos (HsTick c ids (L pos e))
+ ( tickish
, fvs
, st {tickBoxCount=c+1,mixEntries=me:mes}
)
-allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
-allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
- sameFileName pos
- (return Nothing) $ TM $ \ env st ->
- let mydecl_path
- | null (declPath env), TopLevelBox x <- boxLabel = x
- | otherwise = declPath env
- me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
- c = tickBoxCount st
- mes = mixEntries st
- ids = occEnvElts fvs
- in ( Just (c, ids)
- , noFVs
- , st {tickBoxCount=c+1, mixEntries=me:mes}
- )
-allocATickBox _boxLabel _pos _fvs = return Nothing
allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
-> TM (LHsExpr Id)
allocBinTickBox boxLabel pos m
- | not opt_Hpc = allocTickBox (ExpBox False) pos m
+ | not opt_Hpc = allocTickBox (ExpBox False) False False pos m
| isGoodSrcSpan' pos =
do
e <- m
@@ -823,7 +1011,7 @@ allocBinTickBox boxLabel pos m
c = tickBoxCount st
mes = mixEntries st
in
- ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+ ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index d36883462c..b8f1af3a65 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -89,7 +89,6 @@ deSugar hsc_env
-- Desugar the program
; let export_set = availsToNameSet exports
- ; let auto_scc = mkAutoScc dflags mod export_set
; let target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info
; (msgs, mb_res)
@@ -98,15 +97,23 @@ deSugar hsc_env
return (emptyMessages,
Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do
+
+ let want_ticks = opt_Hpc
+ || target == HscInterpreted
+ || (opt_SccProfilingOn
+ && case profAuto dflags of
+ NoProfAuto -> False
+ _ -> True)
+
(binds_cvr,ds_hpc_info, modBreaks)
- <- if (opt_Hpc
- || target == HscInterpreted)
- && (not (isHsBoot hsc_src))
- then addCoverageTicksToBinds dflags mod mod_loc tcs binds
+ <- if want_ticks && not (isHsBoot hsc_src)
+ then addTicksToBinds dflags mod mod_loc export_set
+ (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
+
initDs hsc_env mod rdr_env type_env $ do
do { ds_ev_binds <- dsEvBinds ev_binds
- ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
+ ; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
@@ -215,22 +222,6 @@ and Rec the rest.
\begin{code}
-mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
-mkAutoScc dflags mod exports
- | not opt_SccProfilingOn -- No profiling
- = NoSccs
- -- Add auto-scc on all top-level things
- | dopt Opt_AutoSccsOnAllToplevs dflags
- = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
- -- See #1641. This is pretty yucky, but I can't see a better way
- -- to identify compiler-generated Ids, and at least this should
- -- catch them all.
- -- Only on exported things
- | dopt Opt_AutoSccsOnExportedToplevs dflags
- = AddSccs mod (\id -> idName id `elemNameSet` exports)
- | otherwise
- = NoSccs
-
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index d7d5e7023b..b3fdc8f8b7 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -557,10 +557,9 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do
unionVarSets fv_sets)
-dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) = do
+dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do
(expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr
- expr2 <- mkTickBox ix vars expr1
- return (expr2,id_set)
+ return (Tick tickish expr1, id_set)
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 2b2b3229d7..f207074cd8 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,8 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsEvBinds,
- AutoScc(..)
+ dsHsWrapper, dsTcEvBinds, dsEvBinds,
) where
#include "HsVersions.h"
@@ -39,8 +38,6 @@ import TcType
import Type
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, tupleCon )
-import CostCentre
-import Module
import Id
import Class
import DataCon ( dataConWorkId )
@@ -69,70 +66,68 @@ import MonadUtils
%************************************************************************
\begin{code}
-dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds = ds_lhs_binds binds
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
; return (fromOL binds') }
------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
- -- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
- ; return (foldBag appOL id nilOL ds_bs) }
+ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
+ ; return (foldBag appOL id nilOL ds_bs) }
-dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsLHsBind auto_scc (L loc bind)
- = putSrcSpanDs loc $ dsHsBind auto_scc bind
+dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind (L loc bind)
+ = putSrcSpanDs loc $ dsHsBind bind
-dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
-- so we only need do this here
- ; core_expr' <- addDictScc var core_expr
- ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
+ ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
| otherwise = var
- ; return (unitOL (makeCorePair var' False 0 core_expr')) }
+ ; return (unitOL (makeCorePair var' False 0 core_expr)) }
-dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
- , fun_co_fn = co_fn, fun_tick = tick
- , fun_infix = inf })
+dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
+ , fun_co_fn = co_fn, fun_tick = tick
+ , fun_infix = inf })
= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
- ; body' <- mkOptTickBox tick body
- ; wrap_fn' <- dsHsWrapper co_fn
- ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
- ; return (unitOL (makeCorePair fun False 0 rhs)) }
-
-dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+ ; let body' = mkOptTickBox tick body
+ ; wrap_fn' <- dsHsWrapper co_fn
+ ; let rhs = wrap_fn' (mkLams args body')
+ ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
+ return (unitOL (makeCorePair fun False 0 rhs)) }
+
+dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
+ , pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
- ; sel_binds <- mkSelectorBinds pat body_expr
+ ; let body' = mkOptTickBox rhs_tick body_expr
+ ; sel_binds <- mkSelectorBinds var_ticks pat body'
-- We silently ignore inline pragmas; no makeCorePair
-- Not so cool, but really doesn't matter
- ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
- | (v, expr) <- sel_binds ]
- ; return (toOL sel_binds') }
+ ; return (toOL sel_binds) }
-- A common case: one exported variable
-- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures
-dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
- , abs_exports = [export]
- , abs_ev_binds = ev_binds, abs_binds = binds })
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+ , abs_exports = [export]
+ , abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
- = do { bind_prs <- ds_lhs_binds NoSccs binds
+ = do { bind_prs <- ds_lhs_binds binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; wrap_fn <- dsHsWrapper wrap
; let core_bind = Rec (fromOL bind_prs)
- rhs = addAutoScc auto_scc global $
- wrap_fn $ -- Usually the identity
+ rhs = wrap_fn $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_ev_binds $
Let core_bind $
@@ -146,17 +141,12 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; return (main_bind `consOL` spec_binds) }
-dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
- , abs_exports = exports, abs_ev_binds = ev_binds
- , abs_binds = binds })
- = do { bind_prs <- ds_lhs_binds NoSccs binds
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+ , abs_exports = exports, abs_ev_binds = ev_binds
+ , abs_binds = binds })
+ = do { bind_prs <- ds_lhs_binds binds
; ds_ev_binds <- dsTcEvBinds ev_binds
- ; let env = mkABEnv exports
- do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id
- = (lcl_id, addAutoScc auto_scc (abe_poly export) rhs)
- | otherwise = (lcl_id,rhs)
-
- core_bind = Rec (map do_one (fromOL bind_prs))
+ ; let core_bind = Rec (fromOL bind_prs)
-- Monomorphic recursion possible, hence Rec
tup_expr = mkBigCoreVarTup locals
@@ -181,8 +171,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; let global' = addIdSpecialisations global rules
; return ((global', rhs) `consOL` spec_binds) }
- ; export_binds_s <- mapM mk_bind exports
- -- Don't scc (auto-)annotate the tuple itself.
+ ; export_binds_s <- mapM mk_bind exports
; return ((poly_tup_id, poly_tup_rhs) `consOL`
concatOL export_binds_s) }
@@ -310,17 +299,6 @@ makeCorePair gbl_id is_default_method dict_arity rhs
dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
dictArity dicts = count isId dicts
-
-
-------------------------
-type AbsBindEnv = VarEnv (ABExport Id)
- -- Maps the "lcl_id" for an AbsBind to
- -- its "gbl_id" and associated pragmas, if any
-
-mkABEnv :: [ABExport Id] -> AbsBindEnv
--- Takes the exports of a AbsBinds, and returns a mapping
--- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
-mkABEnv exports = mkVarEnv [ (abe_mono export, export) | export <- exports]
\end{code}
Note [Rules and inlining]
@@ -691,52 +669,6 @@ as the old one, but with an Internal name and no IdInfo.
%************************************************************************
%* *
-\subsection[addAutoScc]{Adding automatic sccs}
-%* *
-%************************************************************************
-
-\begin{code}
-data AutoScc = NoSccs
- | AddSccs Module (Id -> Bool)
--- The (Id->Bool) says which Ids to add SCCs to
--- But we never add a SCC to function marked INLINE
-
-addAutoScc :: AutoScc
- -> Id -- Binder
- -> CoreExpr -- Rhs
- -> CoreExpr -- Scc'd Rhs
-
-addAutoScc NoSccs _ rhs
- = rhs
-addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
- = rhs
-addAutoScc (AddSccs mod add_scc) id rhs
- | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
- | otherwise = rhs
-\end{code}
-
-If profiling and dealing with a dict binding,
-wrap the dict in @_scc_ DICT <dict>@:
-
-\begin{code}
-addDictScc :: Id -> CoreExpr -> DsM CoreExpr
-addDictScc _ rhs = return rhs
-
-{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
- | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
- || not (isDictId var)
- = return rhs -- That's easy: do nothing
-
- | otherwise
- = do (mod, grp) <- getModuleAndGroupDs
- -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
- return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
--}
-\end{code}
-
-
-%************************************************************************
-%* *
Desugaring coercions
%* *
%************************************************************************
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6b476a6ca3..3d79ce7150 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -148,7 +148,7 @@ dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_
= do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn )
- ; rhs' <- mkOptTickBox tick rhs
+ ; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) }
dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
@@ -317,10 +317,11 @@ dsExpr (ExplicitTuple tup_args boxity)
dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs
- Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
+ count <- doptDs Opt_ProfCountEntries
+ Tick (ProfNote (mkUserCC cc mod_name) count True) <$> dsLExpr expr
-dsExpr (HsCoreAnn fs expr)
- = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
+dsExpr (HsCoreAnn _ expr)
+ = dsLExpr expr
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
@@ -586,9 +587,9 @@ dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
Hpc Support
\begin{code}
-dsExpr (HsTick ix vars e) = do
+dsExpr (HsTick tickish e) = do
e' <- dsLExpr e
- mkTickBox ix vars e'
+ return (Tick tickish e')
-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index d3fcf76d1c..9b80852a86 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -140,12 +140,17 @@ isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsTick ix frees e))
- | Just ticks <- isTrueLHsExpr e = Just (\x -> ticks x >>= mkTickBox ix frees)
+isTrueLHsExpr (L _ (HsTick tickish e))
+ | Just ticks <- isTrueLHsExpr e
+ = Just (\x -> ticks x >>= return . (Tick tickish))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L _ (HsBinTick ixT _ e))
- | Just ticks <- isTrueLHsExpr e = Just (\x -> ticks x >>= mkTickBox ixT [])
+ | Just ticks <- isTrueLHsExpr e
+ = Just (\x -> do e <- ticks x
+ this_mod <- getModuleDs
+ return (Tick (HpcTick this_mod ixT) e))
+
isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
\end{code}
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 462137ade8..1bdeafb411 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -35,7 +35,7 @@ module DsUtils (
dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
- mkTickBox, mkOptTickBox, mkBinaryTickBox
+ mkOptTickBox, mkBinaryTickBox
) where
#include "HsVersions.h"
@@ -70,7 +70,8 @@ import SrcLoc
import Util
import ListSetOps
import FastString
-import StaticFlags
+
+import Control.Monad ( zipWithM )
\end{code}
@@ -568,14 +569,17 @@ cases like
(p,q) = e
\begin{code}
-mkSelectorBinds :: LPat Id -- The pattern
+mkSelectorBinds :: [Maybe (Tickish Id)] -- ticks to add, possibly
+ -> LPat Id -- The pattern
-> CoreExpr -- Expression to which the pattern is bound
-> DsM [(Id,CoreExpr)]
-mkSelectorBinds (L _ (VarPat v)) val_expr
- = return [(v, val_expr)]
+mkSelectorBinds ticks (L _ (VarPat v)) val_expr
+ = return [(v, case ticks of
+ [t] -> mkOptTickBox t val_expr
+ _ -> val_expr)]
-mkSelectorBinds pat val_expr
+mkSelectorBinds ticks pat val_expr
| null binders
= return []
@@ -599,7 +603,7 @@ mkSelectorBinds pat val_expr
-- But we need it at different types... so we use coerce for that
; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
; err_var <- newSysLocalDs unitTy
- ; binds <- mapM (mk_bind val_var err_var) binders
+ ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
; return ( (val_var, val_expr) :
(err_var, err_expr) :
binds ) }
@@ -608,22 +612,26 @@ mkSelectorBinds pat val_expr
= do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
; tuple_var <- newSysLocalDs tuple_ty
- ; let mk_tup_bind binder
- = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
- ; return ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) }
+ ; let mk_tup_bind tick binder
+ = (binder, mkOptTickBox tick $
+ mkTupleSelector local_binders binder
+ tuple_var (Var tuple_var))
+ ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
where
binders = collectPatBinders pat
- local_binders = map localiseId binders -- See Note [Localise pattern binders]
+ ticks' = ticks ++ repeat Nothing
+
+ local_binders = map localiseId binders -- See Note [Localise pattern binders]
local_tuple = mkBigCoreVarTup binders
tuple_ty = exprType local_tuple
- mk_bind scrut_var err_var bndr_var = do
+ mk_bind scrut_var err_var tick bndr_var = do
-- (mk_bind sv err_var) generates
-- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
-- Remember, pat binds bv
rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var) error_expr
- return (bndr_var, rhs_expr)
+ return (bndr_var, mkOptTickBox tick rhs_expr)
where
error_expr = mkCoerce co (Var err_var)
co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
@@ -767,38 +775,19 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see Trac #3403.
\begin{code}
-mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
-mkOptTickBox Nothing e = return e
-mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
-
-mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
-mkTickBox ix vars e = do
- uq <- newUnique
- mod <- getModuleDs
- let tick | opt_Hpc = mkTickBoxOpId uq mod ix
- | otherwise = mkBreakPointOpId uq mod ix
- uq2 <- newUnique
- let occName = mkVarOcc "tick"
- let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
- let var = Id.mkLocalId name realWorldStatePrimTy
- scrut <-
- if opt_Hpc
- then return (Var tick)
- else do
- let tickVar = Var tick
- let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
- let scrutApTy = App tickVar (Type tickType)
- return (mkApps scrutApTy (map Var vars) :: Expr Id)
- return $ Case scrut var ty [(DEFAULT,[],e)]
- where
- ty = exprType e
+mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr
+mkOptTickBox Nothing e = e
+mkOptTickBox (Just tickish) e = Tick tickish e
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
uq <- newUnique
- let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
- falseBox <- mkTickBox ixF [] $ Var falseDataConId
- trueBox <- mkTickBox ixT [] $ Var trueDataConId
+ this_mod <- getModuleDs
+ let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
+ let
+ falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
+ trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)
+ --
return $ Case e bndr1 boolTy
[ (DataAlt falseDataCon, [], falseBox)
, (DataAlt trueDataCon, [], trueBox)
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index d2a56d1848..69f378eb1b 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -492,7 +492,7 @@ tidy1 v (AsPat (L _ var) pat)
-}
tidy1 v (LazyPat pat)
- = do { sel_prs <- mkSelectorBinds pat (Var v)
+ = do { sel_prs <- mkSelectorBinds [] pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }