[Git][ghc/ghc][master] 5 commits: Coverage: Drop redundant ad-hoc boot module check

Marge Bot gitlab at gitlab.haskell.org
Mon May 25 13:49:04 UTC 2020



 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
4c4312ed by Ben Gamari at 2020-05-25T09:48:53-04:00
Coverage: Drop redundant ad-hoc boot module check

To determine whether the module is a boot module
Coverage.addTicksToBinds was checking for a `boot` suffix in the module
source filename. This is quite ad-hoc and shouldn't be necessary; the
callsite in `deSugar` already checks that the module isn't a boot
module.

- - - - -
1abf3c84 by Ben Gamari at 2020-05-25T09:48:53-04:00
Coverage: Make tickBoxCount strict

This could otherwise easily cause a leak of (+) thunks.

- - - - -
b2813750 by Ben Gamari at 2020-05-25T09:48:53-04:00
Coverage: Make ccIndices strict

This just seems like a good idea.

- - - - -
02e278eb by Ben Gamari at 2020-05-25T09:48:53-04:00
Coverage: Don't produce ModBreaks if not HscInterpreted

emptyModBreaks contains a bottom and consequently it's important that we
don't use it unless necessary.

- - - - -
b8c014ce by Ben Gamari at 2020-05-25T09:48:53-04:00
Coverage: Factor out addMixEntry

- - - - -


1 changed file:

- compiler/GHC/HsToCore/Coverage.hs


Changes:

=====================================
compiler/GHC/HsToCore/Coverage.hs
=====================================
@@ -78,8 +78,7 @@ addTicksToBinds
 addTicksToBinds hsc_env mod mod_loc exports tyCons binds
   | let dflags = hsc_dflags hsc_env
         passes = coveragePasses dflags, not (null passes),
-    Just orig_file <- ml_hs_file mod_loc,
-    not ("boot" `isSuffixOf` orig_file) = do
+    Just orig_file <- ml_hs_file mod_loc = do
 
      let  orig_file2 = guessSourceFile binds orig_file
 
@@ -118,7 +117,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
      dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
        (pprLHsBinds binds1)
 
-     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
+     return (binds1, HpcInfo tickCount hashNo, modBreaks)
 
   | otherwise = return (binds, emptyHpcInfo False, Nothing)
 
@@ -135,23 +134,23 @@ guessSourceFile binds orig_file =
         _ -> orig_file
 
 
-mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
 mkModBreaks hsc_env mod count entries
-  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+  | breakpointsEnabled (hsc_dflags hsc_env) = do
     breakArray <- GHCi.newBreakArray hsc_env (length entries)
     ccs <- mkCCSArray hsc_env mod count 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 ]
-    return emptyModBreaks
+    return $ Just $ emptyModBreaks
                        { modBreaks_flags = breakArray
                        , modBreaks_locs  = locsTicks
                        , modBreaks_vars  = varsTicks
                        , modBreaks_decls = declsTicks
                        , modBreaks_ccs   = ccs
                        }
-  | otherwise = return emptyModBreaks
+  | otherwise = return Nothing
 
 mkCCSArray
   :: HscEnv -> Module -> Int -> [MixEntry_]
@@ -1004,11 +1003,20 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
                 (addTickLHsExpr e2)
                 (addTickLHsExpr e3)
 
-data TickTransState = TT { tickBoxCount:: Int
+data TickTransState = TT { tickBoxCount:: !Int
                          , mixEntries  :: [MixEntry_]
-                         , ccIndices   :: CostCentreState
+                         , ccIndices   :: !CostCentreState
                          }
 
+addMixEntry :: MixEntry_ -> TM Int
+addMixEntry ent = do
+  c <- tickBoxCount <$> getState
+  setState $ \st ->
+    st { tickBoxCount = c + 1
+       , mixEntries = ent : mixEntries st
+       }
+  return c
+
 data TickTransEnv = TTE { fileName     :: FastString
                         , density      :: TickDensity
                         , tte_dflags   :: DynFlags
@@ -1028,7 +1036,7 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
 
 coveragePasses :: DynFlags -> [TickishType]
 coveragePasses dflags =
-    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+    ifa (breakpointsEnabled dflags)          Breakpoints $
     ifa (gopt Opt_Hpc dflags)                HpcTicks $
     ifa (gopt Opt_SccProfilingOn dflags &&
          profAuto dflags /= NoProfAuto)      ProfNotes $
@@ -1036,6 +1044,10 @@ coveragePasses dflags =
   where ifa f x xs | f         = x:xs
                    | otherwise = xs
 
+-- | Should we produce 'Breakpoint' ticks?
+breakpointsEnabled :: DynFlags -> Bool
+breakpointsEnabled dflags = hscTarget dflags == HscInterpreted
+
 -- | Tickishs that only make sense when their source code location
 -- refers to the current file. This might not always be true due to
 -- LINE pragmas in the code - which would confuse at least HPC.
@@ -1202,11 +1214,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
   dflags <- getDynFlags
   env <- getEnv
   case tickishType env of
-    HpcTicks -> do
-      c <- liftM tickBoxCount getState
-      setState $ \st -> st { tickBoxCount = c + 1
-                           , mixEntries = me : mixEntries st }
-      return $ HpcTick (this_mod env) c
+    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me
 
     ProfNotes -> do
       let nm = mkFastString cc_name
@@ -1215,11 +1223,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
           count = countEntries && gopt Opt_ProfCountEntries dflags
       return $ ProfNote cc count True{-scopes-}
 
-    Breakpoints -> do
-      c <- liftM tickBoxCount getState
-      setState $ \st -> st { tickBoxCount = c + 1
-                           , mixEntries = me:mixEntries st }
-      return $ Breakpoint c ids
+    Breakpoints -> Breakpoint <$> addMixEntry me <*> pure ids
 
     SourceNotes | RealSrcSpan pos' _ <- pos ->
       return $ SourceNote pos' cc_name
@@ -1240,22 +1244,15 @@ allocBinTickBox boxLabel pos m = do
 
 mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
                 -> TM (LHsExpr GhcTc)
-mkBinTickBoxHpc boxLabel pos e =
- TM $ \ env st ->
-  let meT = (pos,declPath env, [],boxLabel True)
-      meF = (pos,declPath env, [],boxLabel False)
-      meE = (pos,declPath env, [],ExpBox False)
-      c = tickBoxCount st
-      mes = mixEntries st
-  in
-     ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
-          $ L pos $ HsBinTick noExtField (c+1) (c+2) e
-   -- notice that F and T are reversed,
-   -- because we are building the list in
-   -- reverse...
-     , noFVs
-     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
-     )
+mkBinTickBoxHpc boxLabel pos e = do
+  env <- getEnv
+  binTick <- HsBinTick noExtField
+    <$> addMixEntry (pos,declPath env, [],boxLabel True)
+    <*> addMixEntry (pos,declPath env, [],boxLabel False)
+    <*> pure e
+  tick <- HpcTick (this_mod env)
+    <$> addMixEntry (pos,declPath env, [],ExpBox False)
+  return $ L pos $ HsTick noExtField tick (L pos binTick)
 
 mkHpcPos :: SrcSpan -> HpcPos
 mkHpcPos pos@(RealSrcSpan s _)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/013d71204be44d660f01f8eb255db2d48b832421...b8c014ce27c279e0d506d5391a4e9bfa7f1c31f2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/013d71204be44d660f01f8eb255db2d48b832421...b8c014ce27c279e0d506d5391a4e9bfa7f1c31f2
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200525/134aa5de/attachment-0001.html>


More information about the ghc-commits mailing list