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, 21 months ago)

Proposed change

  • compiler/deSugar/Coverage.lhs

    From cec8c00ddc2527478da838df88c8911fe0296ed2 Mon Sep 17 00:00:00 2001
    From: Peter Wortmann <scpmw@leeds.ac.uk>
    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)