Ticket #7129: 0001-Annotate-code-in-LINE-pragmas-as-well.patch

File 0001-Annotate-code-in-LINE-pragmas-as-well.patch, 7.5 KB (added by scpmw, 3 years ago)

Proposed change

  • compiler/deSugar/Coverage.lhs

    From cec8c00ddc2527478da838df88c8911fe0296ed2 Mon Sep 17 00:00:00 2001
    From: Peter Wortmann <[email protected]>
    Date: Wed, 8 Aug 2012 16:52:15 +0100
    Subject: [PATCH] Annotate code in {-# LINE #-} pragmas as well
    
    I suppose this was a good idea for HPC, as it assumed that source code
    annotations coming from a source file could only talk about the same
    source file (by how Mix files are saved).
    
    I don't see a reason why cost-centres or source annotations would want
    that kind of behaviour. I introduced a flag for toggling the behaviour
    per tickish.
    
    (plus some minor refactoring, as well as making sure that the same check
    applies to binary tick boxes, where they had apparently been forgotten.)
    ---
     compiler/deSugar/Coverage.lhs |   90 +++++++++++++++++++++++++++--------------
     1 files changed, 59 insertions(+), 31 deletions(-)
    
    diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
    index d3fbe4c..2f5ef71 100644
    a b addTicksToBinds dflags mod mod_loc exports tyCons binds = 
    8989                                          | tyCon <- tyCons ]
    9090                      , density      = mkDensity dflags
    9191                      , this_mod     = mod
     92                      , tickishType  = case hscTarget dflags of
     93                          HscInterpreted          -> Breakpoints
     94                          _ | opt_Hpc             -> HpcTicks
     95                            | dopt Opt_SccProfilingOn dflags
     96                                                  -> ProfNotes
     97                            | otherwise           -> error "addTicksToBinds: No way to annotate!"
    9298                       })
    9399                   (TT
    94100                      { tickBoxCount = 0
    data TickTransEnv = TTE { fileName :: FastString 
    910916                        , inScope      :: VarSet
    911917                        , blackList    :: Map SrcSpan ()
    912918                        , this_mod     :: Module
     919                        , tickishType  :: TickishType
    913920                        }
    914921
    915922--      deriving Show
    916923
     924data TickishType = ProfNotes | HpcTicks | Breakpoints
     925
     926
     927-- | Tickishs that only make sense when their source code location
     928-- refers to the current file. This might not always be true due to
     929-- LINE pragmas in the code - which would confuse at least HPC.
     930tickSameFileOnly :: TickishType -> Bool
     931tickSameFileOnly HpcTicks = True
     932tickSameFileOnly _other   = False
     933
    917934type FreeVars = OccEnv Id
    918935noFVs :: FreeVars
    919936noFVs = emptyOccEnv
    getPathEntry = declPath `liftM` getEnv 
    982999getFileName :: TM FastString
    9831000getFileName = fileName `liftM` getEnv
    9841001
    985 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
    986 sameFileName pos out_of_scope in_scope = do
     1002isGoodSrcSpan' :: SrcSpan -> Bool
     1003isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
     1004isGoodSrcSpan' (UnhelpfulSpan _) = False
     1005
     1006isGoodTickSrcSpan :: SrcSpan -> TM Bool
     1007isGoodTickSrcSpan pos = do
    9871008  file_name <- getFileName
    988   case srcSpanFileName_maybe pos of
    989     Just file_name2
    990       | file_name == file_name2 -> in_scope
    991     _ -> out_of_scope
     1009  tickish <- tickishType `liftM` getEnv
     1010  let need_same_file = tickSameFileOnly tickish
     1011      same_file      = Just file_name == srcSpanFileName_maybe pos
     1012  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
     1013
     1014ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
     1015ifGoodTickSrcSpan pos then_code else_code = do
     1016  good <- isGoodTickSrcSpan pos
     1017  if good then then_code else else_code
    9921018
    9931019bindLocals :: [Id] -> TM a -> TM a
    9941020bindLocals new_ids (TM m)
    isBlackListed pos = TM $ \ env st -> 
    10071033-- expression argument to support nested box allocations
    10081034allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
    10091035             -> TM (LHsExpr Id)
    1010 allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
    1011   sameFileName pos (do e <- m; return (L pos e)) $ do
     1036allocTickBox boxLabel countEntries topOnly pos m =
     1037  ifGoodTickSrcSpan pos (do
    10121038    (fvs, e) <- getFreeVars m
    10131039    env <- getEnv
    10141040    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
    10151041    return (L pos (HsTick tickish (L pos e)))
    1016 allocTickBox _boxLabel _countEntries _topOnly pos m = do
    1017   e <- m
    1018   return (L pos e)
    1019 
     1042  ) (do
     1043    e <- m
     1044    return (L pos e)
     1045  )
    10201046
    10211047-- the tick application inherits the source position of its
    10221048-- expression argument to support nested box allocations
    10231049allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
    10241050              -> TM (Maybe (Tickish Id))
    1025 allocATickBox boxLabel countEntries topOnly  pos fvs | isGoodSrcSpan' pos =
    1026   sameFileName pos (return Nothing) $ do
     1051allocATickBox boxLabel countEntries topOnly  pos fvs =
     1052  ifGoodTickSrcSpan pos (do
    10271053    let
    10281054      mydecl_path = case boxLabel of
    10291055                      TopLevelBox x -> x
    allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos = 
    10311057                      _ -> panic "allocATickBox"
    10321058    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
    10331059    return (Just tickish)
    1034 allocATickBox _boxLabel _countEntries _topOnly _pos _fvs =
    1035   return Nothing
     1060  ) (return Nothing)
    10361061
    10371062
    10381063mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
    mkTickish boxLabel countEntries topOnly pos fvs decl_path = 
    10591084
    10601085        count = countEntries && dopt Opt_ProfCountEntries dflags
    10611086
    1062         tickish
    1063           | opt_Hpc                        = HpcTick (this_mod env) c
    1064           | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-}
    1065           | otherwise                      = Breakpoint c ids
     1087        tickish = case tickishType env of
     1088          HpcTicks    -> HpcTick (this_mod env) c
     1089          ProfNotes   -> ProfNote cc count True{-scopes-}
     1090          Breakpoints -> Breakpoint c ids
     1091          _otherwise  -> panic "mkTickish: bad source span!"
    10661092    in
    10671093    ( tickish
    10681094    , fvs
    mkTickish boxLabel countEntries topOnly pos fvs decl_path = 
    10721098
    10731099allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
    10741100                -> TM (LHsExpr Id)
    1075 allocBinTickBox boxLabel pos m
    1076  | not opt_Hpc = allocTickBox (ExpBox False) False False pos m
    1077  | isGoodSrcSpan' pos =
    1078  do
    1079  e <- m
     1101allocBinTickBox boxLabel pos m = do
     1102  env <- getEnv
     1103  case tickishType env of
     1104    HpcTicks -> do e <- liftM (L pos) m
     1105                   ifGoodTickSrcSpan pos
     1106                     (mkBinTickBoxHpc boxLabel pos e)
     1107                     (return e)
     1108    _other   -> allocTickBox (ExpBox False) False False pos m
     1109
     1110mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id
     1111                -> TM (LHsExpr Id)
     1112mkBinTickBoxHpc boxLabel pos e =
    10801113 TM $ \ env st ->
    10811114  let meT = (pos,declPath env, [],boxLabel True)
    10821115      meF = (pos,declPath env, [],boxLabel False)
    allocBinTickBox boxLabel pos m 
    10841117      c = tickBoxCount st
    10851118      mes = mixEntries st
    10861119  in
    1087              ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
     1120             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
    10881121           -- notice that F and T are reversed,
    10891122           -- because we are building the list in
    10901123           -- reverse...
    10911124             , noFVs
    10921125             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
    10931126             )
    1094 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
    1095 
    1096 isGoodSrcSpan' :: SrcSpan -> Bool
    1097 isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
    1098 isGoodSrcSpan' (UnhelpfulSpan _) = False
    10991127
    11001128mkHpcPos :: SrcSpan -> HpcPos
    11011129mkHpcPos pos@(RealSrcSpan s)