[Git][ghc/ghc][wip/expand-do] simplifying the ticking logic

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
f3309938 by Apoorv Ingle at 2023-12-21T11:39:35-06:00
simplifying the ticking logic

- - - - -


1 changed file:

- compiler/GHC/HsToCore/Ticks.hs


Changes:

=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -375,7 +375,7 @@ addTickLHsExpr e@(L pos e0) = do
   d <- getDensity
   case d of
     TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
-    TickForCoverage    | XExpr (ExpandedThingTc OrigStmt{} _) <- e0
+    TickForCoverage    | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately
                        -> dont_tick_it
                        | otherwise -> tick_it
     TickCallSites      | isCallSite e0      -> tick_it
@@ -589,7 +589,7 @@ addTickHsExpr (HsProc x pat cmdtop) =
 addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
         liftM (XExpr . WrapExpr . HsWrap w) $
               (addTickHsExpr e)        -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsXExpr o e
+addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
 
 addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
   -- We used to do a freeVar on a pat-syn builder, but actually
@@ -610,8 +610,9 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
                     ListComp -> Just $ BinBox QualBinBox
                     _        -> Nothing
 
-addTickHsXExpr :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsXExpr o@(OrigStmt (L pos LastStmt{})) e
+addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e
+  -- LastStmt always gets a tick for breakpoint and hpc coverage
   = do d <- getDensity
        case d of
           TickForCoverage    -> liftM (XExpr . ExpandedThingTc o) $ tick_it pos e
@@ -620,7 +621,7 @@ addTickHsXExpr o@(OrigStmt (L pos LastStmt{})) e
   where
     tick_it pos e  = unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
                                (addTickHsExpr e)
-addTickHsXExpr o e
+addTickHsExpanded o e
   = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e
 
 
@@ -668,13 +669,15 @@ addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do
   d <- getDensity
   case d of
     TickForBreakPoints
-      | XExpr (ExpandedThingTc thing _) <- e0
-      , OrigStmt (L _ LastStmt{}) <- thing -> addTickLHsExprRHS expr
-      | isDoExp -> addTickLHsExprNever expr
+      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`
+      -> addTickLHsExprNever expr
+      | otherwise
+      -> addTickLHsExprRHS expr
     TickForCoverage
-      | XExpr (ExpandedThingTc OrigStmt{} _) <- e0
+      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`
       -> addTickLHsExprNever expr
-      | otherwise -> addTickLHsExprOptAlt isOneOfMany expr
+      | otherwise
+      -> addTickLHsExprOptAlt isOneOfMany expr
     TickAllFunctions | isLambda ->
        addPathEntry "\\" $
          allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3309938affd76b7ac47933b60e80e0ee140ca32

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3309938affd76b7ac47933b60e80e0ee140ca32
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/20231221/010a6f84/attachment-0001.html>