[Git][ghc/ghc][wip/expand-do] some more trials for debugger

[Apoorv Ingle (@ani)]

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


Commits:
46c0e7c7 by Apoorv Ingle at 2023-09-24T23:10:54-05:00
some more trials for debugger

- - - - -


4 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -831,7 +831,10 @@ instance Outputable XXExprGhcTc where
 
   ppr (HsTick tickish exp) =
     pprTicks (ppr exp) $
-      ppr tickish <+> ppr_lexpr exp
+      hcat [ text "tick<"
+           , ppr tickish
+           , text ">"
+           , ppr_lexpr exp]
 
   ppr (HsBinTick tickIdTrue tickIdFalse exp) =
     pprTicks (ppr exp) $


=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -374,8 +374,14 @@ addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTickLHsExpr e@(L pos e0) = do
   d <- getDensity
   case d of
-    TickForBreakPoints | XExpr (ExpansionStmt{}) <- e0
+    TickForBreakPoints | XExpr (ExpansionStmt (HsExpanded stmt _)) <- e0
+                       , L _ BodyStmt{} <- stmt
                        -> dont_tick_it
+                       | XExpr (ExpansionStmt (HsExpanded stmt _)) <- e0
+                       , L _ BindStmt{} <- stmt
+                       -> dont_tick_it
+                       | XExpr (ExpansionStmt{}) <- e0
+                       -> tick_it
                        | isGoodBreakExpr e0 -> tick_it
     TickForCoverage    -> tick_it
     TickCallSites      | isCallSite e0      -> tick_it
@@ -393,8 +399,9 @@ addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTickLHsExprRHS e@(L pos e0) = do
   d <- getDensity
   case d of
-     TickForBreakPoints | HsLet{}    <- e0  -> dont_tick_it
-                        | XExpr (ExpansionStmt{}) <- e0 -> dont_tick_it
+     TickForBreakPoints | HsLet{}    <- e0
+                        , not (isGeneratedSrcSpan $ locA pos) -> dont_tick_it
+                        -- if its a user written let statement tick it
                         | otherwise -> tick_it
      TickForCoverage -> tick_it
      TickCallSites   | isCallSite e0 -> tick_it
@@ -598,20 +605,9 @@ addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
 addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
         liftM (XExpr . ExpansionExpr . HsExpanded a) $
               (addTickHsExpr b)
-addTickHsExpr (XExpr (ExpansionStmt (HsExpanded a b)))
-  | L pos LastStmt{} <- a
-  = liftM (XExpr . ExpansionStmt . HsExpanded a) $
-          (unLoc <$> tick_it pos b)
-
-  | L pos BindStmt{} <- a
-  = liftM (XExpr . ExpansionStmt . HsExpanded a) $
-          (unLoc <$> tick_it pos b)
-  | otherwise
-  = liftM (XExpr . ExpansionStmt . HsExpanded a) $
-          addTickHsExpr b
-  where
-    tick_it pos e0  = allocTickBox (ExpBox False) False False (locA pos)
-                      $ addTickHsExpr e0
+addTickHsExpr (XExpr (ExpansionStmt (HsExpanded a b))) =
+        liftM (XExpr . ExpansionStmt . HsExpanded a) $
+              (addTickHsExpr b)
 
 addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
   -- We used to do a freeVar on a pat-syn builder, but actually
@@ -640,9 +636,12 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
 addTickMatch :: Bool{-is a Lambda-} -> Bool -> Match GhcTc (LHsExpr GhcTc)
              -> TM (Match GhcTc (LHsExpr GhcTc))
 addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
-                                               , m_grhss = gRHSs }) =
+                                               , m_grhss = gRHSs
+                                               , m_ctxt = ctxt }) =
   bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+    gRHSs' <- case ctxt of
+                StmtCtxt{} -> addTickGRHSs isOneOfMany False gRHSs
+                _          -> addTickGRHSs isOneOfMany isLambda gRHSs
     return $ match { m_grhss = gRHSs' }
 
 addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -539,7 +539,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
       = DoOrigin
       | VAExpansionPat pat _ <- fun_ctxt
       = DoPatOrigin pat
-      | VAExpansion e _ <- fun_ctxt
+      | VAExpansion e _ _ <- fun_ctxt
       = exprCtOrigin e
       | VACall e _ _ <- fun_ctxt
       = exprCtOrigin e


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -264,10 +264,9 @@ insideExpansion (VACall {})      = False -- but what if the VACall has a generat
 
 instance Outputable AppCtxt where
   ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
-  ppr (VACall f n _)    = text "VACall" <+> int n <+> ppr f
+  ppr (VACall f n l)    = text "VACall" <+> int n <+> ppr f  <+> ppr l
   ppr (VAExpansionStmt stmt l) = text "VAExpansionStmt" <+> ppr stmt <+> ppr l
   ppr (VAExpansionPat pat l) = text "VAExpansionPat" <+> ppr pat <+> ppr l
-  ppr (VACall f n l)    = text "VACall" <+> int n <+> ppr f <+> ppr l
 
 type family XPass p where
   XPass 'TcpRn   = 'Renamed
@@ -329,7 +328,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
     go (HsApp _ (L l fun) arg)       ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg   : args)
 
     -- See Note [Looking through HsExpanded]
-    go (XExpr (HsExpanded orig fun)) ctxt args
+    go (XExpr (ExpandedExpr (HsExpanded orig fun))) ctxt args
       = go fun (VAExpansion orig (appCtxtLoc ctxt) (appCtxtLoc ctxt))
                (EWrap (EExpand orig) : args)
 



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46c0e7c7c50e5683c8beb62b05f4c3bca2247136
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/20230925/ad3bdd1a/attachment-0001.html>