diff options
Diffstat (limited to 'compiler/deSugar')
-rw-r--r-- | compiler/deSugar/Coverage.lhs | 556 | ||||
-rw-r--r-- | compiler/deSugar/Desugar.lhs | 35 | ||||
-rw-r--r-- | compiler/deSugar/DsArrows.lhs | 5 | ||||
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 146 | ||||
-rw-r--r-- | compiler/deSugar/DsExpr.lhs | 13 | ||||
-rw-r--r-- | compiler/deSugar/DsGRHSs.lhs | 11 | ||||
-rw-r--r-- | compiler/deSugar/DsUtils.lhs | 71 | ||||
-rw-r--r-- | compiler/deSugar/Match.lhs | 2 |
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)) } |