[Git][ghc/ghc][wip/expand-do] some more trials for debugger
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Sep 25 04:28:29 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
d2815ac6 by Apoorv Ingle at 2023-09-24T23:28:05-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
@@ -632,17 +628,23 @@ addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches
+ , mg_ext = ext }) = do
let isOneOfMany = matchesOneOfMany matches
- matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches
+ matches' <- case isDoExpansionGenerated (mg_origin ext) of
+ Just _ -> mapM (traverse (addTickMatch isOneOfMany False)) matches
+ Nothing -> mapM (traverse (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = L l matches' }
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/d2815ac671da372da52776b03aca2eee75c77228
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2815ac671da372da52776b03aca2eee75c77228
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/dd6abfe7/attachment-0001.html>
More information about the ghc-commits
mailing list