[Git][ghc/ghc][wip/expand-do] some more trials for debugger
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Sep 25 14:39:53 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
a529583a by Apoorv Ingle at 2023-09-25T09:37:25-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
@@ -595,23 +602,20 @@ 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 (ExpansionExpr (HsExpanded a@(HsDo _ _ (L pos _)) b))) =
+ liftM (XExpr . ExpansionExpr . HsExpanded a) $
+ do lb' <- allocTickBox (ExpBox False) False False (locA pos) $ addTickHsExpr b
+ return $ unLoc lb'
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@(L pos LastStmt{}) b))) =
+ liftM (XExpr . ExpansionStmt . HsExpanded a) $
+ do lb' <- allocTickBox (ExpBox False) False False (locA pos) $ addTickHsExpr b
+ return $ unLoc lb'
+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,9 +636,12 @@ 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)
@@ -649,7 +656,8 @@ addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =
bindLocals binders $ do
- local_binds' <- addTickHsLocalBinds local_binds
+ local_binds' <- if isLambda then addTickHsLocalBinds local_binds
+ else return local_binds
guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded
return $ GRHSs x guarded' local_binds'
where
@@ -671,6 +679,8 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
addPathEntry "\\" $
allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $
addTickHsExpr e0
+ TickForBreakPoints | isLambda -> addTickLHsExprRHS expr
+ | otherwise -> addTickLHsExprNever expr
_otherwise ->
addTickLHsExprRHS expr
=====================================
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/a529583a96ce9028b1a35710c1abb76efe1c3903
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a529583a96ce9028b1a35710c1abb76efe1c3903
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/54e7525d/attachment-0001.html>
More information about the ghc-commits
mailing list