[Git][ghc/ghc][wip/ani/tc-expand] 2 commits: make HsExpandedRn and HsExpandedTc payload LExpr,
by Apoorv Ingle (＠ani) 19 Mar '26
by Apoorv Ingle (＠ani) 19 Mar '26
19 Mar '26
Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC
Commits:
c056178d by Apoorv Ingle at 2026-03-19T08:58:12-05:00
make HsExpandedRn and HsExpandedTc payload LExpr,
add tcExpand for expanding Do expressions before typechecking in tcExpr
- - - - -
48d25b0c by Apoorv Ingle at 2026-03-19T08:58:48-05:00
making HsExpansion a new datatype
- - - - -
20 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -660,44 +660,24 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
+-- See Note [Rebindable syntax and XXExprGhcRn]
+-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+data HsExpansion p = HSE { hs_ctxt :: HsCtxt -- The original source thing context to be used for error messages
+ , expanded_expr :: LHsExpr p } -- The compiler generated, expanded expression
+ -- This is located because of do statements (TODO ANI : Add Note)
+
data XXExprGhcRn
- = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages
- , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing
- }
+ = ExpandedThingRn (HsExpansion GhcRn) -- ^ Renamed/Pre Typecheck expanded expression
| HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector
-- See Note [Non-overloaded record field selectors] and
-- Note [Record selectors in the AST]
--- | Build an expression using the extension constructor `XExpr`,
--- and the two components of the expansion: original expression and
--- expanded expressions.
-mkExpandedExpr
- :: HsExpr GhcRn -- ^ source expression context
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = ExprCtxt oExpr
- , xrn_expanded = eExpr })
-
--- | Build an expression using the extension constructor `XExpr`,
--- and the two components of the expansion: original do stmt and
--- expanded expression
-mkExpandedStmt
- :: ExprLStmt GhcRn -- ^ source statement context
- -> HsDoFlavour -- ^ source statements do flavour
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = StmtErrCtxt (HsDoStmt flav) oStmt
- , xrn_expanded = eExpr })
-
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
- | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
- -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- { xtc_orig :: HsCtxt -- The original user written thing
- , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
+ | ExpandedThingTc (HsExpansion GhcTc) -- ^ Typechecked expanded expression
| ConLikeTc
-- ^ A 'ConLike', either a data constructor or pattern synonym
@@ -722,22 +702,6 @@ data XXExprGhcTc
-- See Note [Non-overloaded record field selectors] and
-- Note [Record selectors in the AST]
-
--- | Build a 'XXExprGhcRn' out of an extension constructor,
--- and the two components of the expansion: original and
--- expanded typechecked expressions.
-mkExpandedExprTc
- :: HsExpr GhcRn -- ^ source expression
- -> HsExpr GhcTc -- ^ expanded typechecked expression
- -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) eExpr
-
-mkExpandedTc
- :: HsCtxt -- ^ source, user written do statement/expression
- -> HsExpr GhcTc -- ^ expanded typechecked expression
- -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedTc o e = XExpr (ExpandedThingTc o e)
-
{- *********************************************************************
* *
Pretty-printing expressions
@@ -1055,9 +1019,15 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
-instance Outputable XXExprGhcRn where
- ppr (HsRecSelRn f) = pprPrefixOcc f
- ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
+
+ppr_hse :: forall p. (IsPass p) => HsExpansion (GhcPass p) -> SDoc
+ppr_hse hse
+ = case ghcPass @p of
+ GhcPs -> empty
+ GhcRn -> case hse of
+ HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
+ GhcTc -> case hse of
+ HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
where
ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x
pprCtxt :: HsCtxt -> SDoc
@@ -1067,26 +1037,17 @@ instance Outputable XXExprGhcRn where
pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e)
pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty
+instance Outputable XXExprGhcRn where
+ ppr (HsRecSelRn f) = pprPrefixOcc f
+ ppr (ExpandedThingRn hse) = ppr_hse hse
+
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr co_fn e)
= pprHsWrapper co_fn (\_parens -> pprExpr e)
- ppr (ExpandedThingTc o e)
- = ifPprDebug (braces $ vcat [pprCtxt o, ppr e]) (pprCtxt o)
-
- where
- ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x
- pprCtxt :: HsCtxt -> SDoc
- pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e)
- pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt)
- pprCtxt (StmtErrCtxtPat pat) = ppr_builder "<OrigPat>:" (ppr pat)
- pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e)
- pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty
-
- -- e is the expanded expression, we print the original
- -- expression (HsExpr GhcRn), not the
- -- expanded typechecked one (HsExpr GhcTc),
- -- unless we are in ppr's debug mode printed both
+ ppr (ExpandedThingTc hse)
+ = ppr_hse hse
ppr (ConLikeTc con) = pprPrefixOcc con
-- Used in error messages generated by
@@ -1119,12 +1080,12 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn (HSE thing _)) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e
-ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_tc (ExpandedThingTc (HSE thing _)) = ppr_infix_hs_expansion thing
ppr_infix_expr_tc (ConLikeTc con) = Just (pprInfixOcc (conLikeName con))
ppr_infix_expr_tc (HsTick {}) = Nothing
ppr_infix_expr_tc (HsBinTick {}) = Nothing
@@ -1212,14 +1173,14 @@ hsExprNeedsParens prec = go
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e
- go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing
+ go_x_tc (ExpandedThingTc (HSE thing _)) = hsExpandedNeedsParens thing
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsRecSelTc{}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing
+ go_x_rn (ExpandedThingRn (HSE thing _)) = hsExpandedNeedsParens thing
go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: HsCtxt -> Bool
@@ -1264,14 +1225,14 @@ isAtomicHsExpr (XExpr x)
where
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr _ e) = isAtomicHsExpr e
- go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
+ go_x_tc (ExpandedThingTc (HSE thing _)) = isAtomicExpandedThingRn thing
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
go_x_tc (HsRecSelTc{}) = True
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (ExpandedThingRn (HSE thing _)) = isAtomicExpandedThingRn thing
go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: HsCtxt -> Bool
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -647,6 +647,9 @@ instance Data HsCtxt where
deriving instance Data XXExprGhcRn
+deriving instance Data (HsExpansion GhcRn)
+deriving instance Data (HsExpansion GhcTc)
+
deriving instance Data a => Data (WithUserRdr a)
-- -------------------------------
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -153,7 +153,7 @@ hsExprType (HsQual x _ _) = dataConCantHappen x
hsExprType (HsForAll x _ _) = dataConCantHappen x
hsExprType (HsFunArr x _ _ _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
+hsExprType (XExpr (ExpandedThingTc (HSE _ e))) = lhsExprType e
hsExprType (XExpr (ConLikeTc con)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Hs
-- needs to see source types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.ErrCtxt
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Class (lookupHasFieldLabel)
@@ -308,10 +307,7 @@ dsExpr e@(XExpr ext_expr_tc)
WrapExpr {} -> dsApp e
ConLikeTc {} -> dsApp e
- ExpandedThingTc o e
- | StmtErrCtxt _ (L loc _) <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc
- -> putSrcSpanDsA loc $ dsExpr e
- | otherwise -> dsExpr e
+ ExpandedThingTc (HSE _ e) -> dsLExpr e
-- Hpc Support
HsTick tickish e -> do
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -1166,8 +1166,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- we have to compare the wrappers
exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =
wrap h h' && exp e e'
- exp (XExpr (ExpandedThingTc _ x)) (XExpr (ExpandedThingTc _ x'))
- = exp x x'
+ exp (XExpr (ExpandedThingTc (HSE _ x))) (XExpr (ExpandedThingTc (HSE _ x')))
+ = lexp x x'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (HsIPVar _ i) (HsIPVar _ i') =
-- the instance for IPName derives using the id, so follow the HsVar case
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1739,7 +1739,7 @@ repE e@(XExpr (ExpandedThingRn o x))
| ExprCtxt e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
- then repE x
+ then repLE x
else repE e }
| otherwise
= notHandled (ThExpressionForm e)
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -415,7 +415,7 @@ addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
- TickForCoverage | XExpr (ExpandedThingTc StmtErrCtxt{} _) <- e0 -- expansion ticks are handled separately
+ TickForCoverage | XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _)) <- e0 -- expansion ticks are handled separately
-> dont_tick_it
| otherwise -> tick_it
TickCallSites | isCallSite e0 -> tick_it
@@ -484,15 +484,15 @@ addTickLHsExprNever (L pos e0) = do
-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (XExpr (ExpandedThingTc (StmtErrCtxt{}) _)) = False
+isGoodBreakExpr (XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _))) = False
isGoodBreakExpr e = isCallSite e
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppType{} = True
isCallSite HsCase{} = True
-isCallSite (XExpr (ExpandedThingTc _ e))
- = isCallSite e
+isCallSite (XExpr (ExpandedThingTc (HSE _ e)))
+ = isCallSite (unLoc e)
-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite _ = False
@@ -637,7 +637,7 @@ addTickHsExpr (HsProc x pat cmdtop) =
addTickHsExpr (XExpr (WrapExpr w e)) =
liftM (XExpr . WrapExpr w) $
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
+addTickHsExpr (XExpr (ExpandedThingTc hse)) = addTickHsExpanded hse
addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-- We used to do a freeVar on a pat-syn builder, but actually
@@ -660,14 +660,14 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
-addTickHsExpanded :: HsCtxt -> HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
+addTickHsExpanded :: HsExpansion GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpanded (HSE o e) = liftM (XExpr . ExpandedThingTc . HSE o) $ case o of
-- We always want statements to get a tick, so we can step over each one.
-- To avoid duplicates we blacklist SrcSpans we already inserted here.
StmtErrCtxt _ (L pos _) -> do_tick_black pos
_ -> skip
where
- skip = addTickHsExpr e
+ skip = addTickLHsExpr e
do_tick_black pos = do
d <- getDensity
case d of
@@ -675,9 +675,9 @@ addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
TickForBreakPoints -> tick_it_black pos
_ -> skip
tick_it_black pos =
- unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
+ allocTickBox (ExpBox False) False False (locA pos)
(withBlackListed (locA pos) $
- addTickHsExpr e)
+ addTickHsExpr (unLoc e))
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -755,10 +755,10 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
- XExpr (ExpandedThingTc thing e)
+ XExpr (ExpandedThingTc (HSE thing e))
| ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax
- -> Just (hsExprType e)
- | otherwise -> computeType e
+ -> Just (lhsExprType e)
+ | otherwise -> computeLType e
XExpr (HsTick _ e) -> computeLType e
XExpr (HsBinTick _ _ e) -> computeLType e
e -> Just (hsExprType e)
@@ -1352,8 +1352,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
WrapExpr w a
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
- ExpandedThingTc _ e
- -> [ toHie (L mspan e) ]
+ ExpandedThingTc (HSE _ e)
+ -> [ toHie e ]
ConLikeTc con
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
HsTick _ expr
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -24,6 +24,8 @@ module GHC.Rename.Utils (
genSimpleFunBind, genFunBind,
genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet,
+ mkExpandedRn, mkExpandedExpr, mkExpandedStmt, mkExpandedLExpr, mkExpandedTc, mkExpandedExprTc,
+
mkRnSyntaxExpr,
newLocalBndrRn, newLocalBndrsRn,
@@ -45,7 +47,6 @@ import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
--- import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -816,3 +817,51 @@ genSimpleMatch ctxt pats rhs
= wrapGenSpan $
Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats
, m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
+
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original expression and
+-- expanded expressions.
+mkExpandedExpr
+ :: HsExpr GhcRn -- ^ source expression context
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) (wrapGenSpan eExpr)
+
+mkExpandedLExpr
+ :: HsExpr GhcRn -- ^ source expression context
+ -> LHsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedLExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) eExpr
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original do stmt and
+-- expanded expression
+mkExpandedStmt
+ :: ExprLStmt GhcRn -- ^ source statement context
+ -> HsDoFlavour -- ^ source statements do flavour
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedStmt oStmt flav eExpr = mkExpandedRn (StmtErrCtxt (HsDoStmt flav) oStmt) (wrapGenSpan eExpr)
+
+mkExpandedRn
+ :: HsCtxt -- ^ source, user written do statement/expression
+ -> LHsExpr GhcRn -- ^ expanded typechecked expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedRn o e = XExpr (ExpandedThingRn (HSE o e))
+
+
+-- | Build a 'XXExprGhcRn' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- expanded typechecked expressions.
+mkExpandedExprTc
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) (wrapGenSpan eExpr)
+
+mkExpandedTc
+ :: HsCtxt -- ^ source, user written do statement/expression
+ -> LHsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc'
+mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e))
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -957,8 +957,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside
, ppr arg
, ppr arg_no])
; setSrcSpanA arg_loc $
- addNthFunArgErrCtxt app_head arg arg_no $
- thing_inside
+ addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
+ thing_inside
}
| otherwise
= do { traceTc "addArgCtxt" (vcat [text "generated Head"
@@ -969,16 +969,6 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside
; addLExprCtxt (locA arg_loc) arg $
thing_inside
}
- where
- addNthFunArgErrCtxt :: HsExpr GhcRn -> HsExpr GhcRn -> Int -> TcM a -> TcM a
- addNthFunArgErrCtxt app_head arg arg_no thing_inside
- | XExpr (ExpandedThingRn _ _) <- arg
- = addExpansionErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
- thing_inside
- | otherwise
- = addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
- thing_inside
-
{- *********************************************************************
@@ -1256,7 +1246,7 @@ expr_to_type earg =
| otherwise = not_in_scope
where occ = occName rdr
not_in_scope = failWith $ TcRnNotInScope NotInScope rdr
- go (L l (XExpr (ExpandedThingRn (ExprCtxt orig) _))) =
+ go (L l (XExpr (ExpandedThingRn (HSE (ExprCtxt orig) _)))) =
-- Use the original, user-written expression (before expansion).
-- Example. Say we have vfun :: forall a -> blah
-- and the call vfun (Maybe [1,2,3])
@@ -1947,16 +1937,13 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn
-> Scaled TcRhoType -- Deeply skolemised
-> TcM (HsExprArg 'TcpInst)
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
-quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Scaled _ orig_arg_rho)
+quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
= addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints
-- generated by calls in arg
- do { ((rn_fun_arg, fun_lspan_arg'), rn_args) <- splitHsApps arg
- ; let fun_lspan_arg | null rn_args = locA arg_loc -- arg is an id (or an XExpr) so use the arg_loc in tcInstFun
- | otherwise = fun_lspan_arg'
+ do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
- ; (fun_ue, mb_fun_ty) <- maybe_update_err_ctxt fun_lspan_arg rn_fun_arg $
- (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg)
+ ; (fun_ue, mb_fun_ty) <- (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg)
-- tcCollectingUsage: the use of an Id at the head generates usage-info
-- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must
-- capture and save it in the `EValArgQL`. See (QLA6) in
@@ -1981,7 +1968,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
<- captureConstraints $
tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
-- We must capture type-class and equality constraints here, but
- -- not equality constraints. See (QLA6) in Note [Quick Look at
+ -- not usage information. See (QLA6) in Note [Quick Look at
-- value arguments]
; traceTc "quickLookArg 2" $
@@ -2025,20 +2012,6 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
, eaql_res_rho = app_res_rho }) }}}
-maybe_update_err_ctxt :: SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a
-maybe_update_err_ctxt fun_lspan_arg rn_fun_arg thing_inside
- | not (isGeneratedSrcSpan fun_lspan_arg)
- , XExpr (ExpandedThingRn{}) <- rn_fun_arg
- = do igc <- inGeneratedCode
- if igc
- then thing_inside
- else addLExprCtxt fun_lspan_arg rn_fun_arg $
- thing_inside
- | otherwise
- = thing_inside
-
-
-
mk_origin :: SrcSpan -- SrcSpan of the argument
-> HsExpr GhcRn -- The head of the expression application chain
-> TcM CtOrigin
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -14,8 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
- genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Utils
import GHC.Rename.Env ( irrefutableConLikeRn )
import GHC.Tc.Utils.Monad
@@ -46,7 +45,7 @@ import Data.List ((\\))
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
-expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpansion GhcRn)
expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts
-- | The main work horse for expanding do block statements into applications of binds and thens
@@ -114,7 +113,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
-- stmts ~~> stmts'
@@ -122,7 +121,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn t
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ L e_lspan (mkExpandedStmt stmt doFlavour e)
+ [ wrapGenSpan e
, expand_stmts_expr ]
return $ L loc (mkExpandedStmt stmt doFlavour expansion)
@@ -235,7 +234,7 @@ See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion
(`HsExpr GhcRn -> HsExpr GhcRn`)
-This expansion is done right before typechecking and after renaming
+This expansion is done after renaming and before typechecking
See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr`
Historical note START
@@ -424,10 +423,10 @@ It stores the original statement (with location) and the expanded expression
‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression
-- Expanded Do Expression
(‹ExpandedThingRn e1› -- Original Statement
- ({(>>) ‹ExpandedThingRn e1› e1} -- Expanded Expression
+ ({(>>) e1} -- Expanded Expression
(‹ExpandedThingRn e2›
- ({(>>) ‹ExpandedThingRn e2› e2}
- (‹ExpandedThingRn e3› {e3})))))
+ ({(>>) e2}
+ (‹ExpandedThingRn e3› {e3})))))
* Whenever the typechecker steps through an `ExpandedThingRn`,
we push the original statement in the error context, set the error location to the
@@ -482,6 +481,4 @@ It stores the original statement (with location) and the expanded expression
mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
-mkExpandedPatRn pat e = XExpr $ ExpandedThingRn
- { xrn_orig = StmtErrCtxtPat pat
- , xrn_expanded = e}
+mkExpandedPatRn pat e = mkExpandedRn (StmtErrCtxtPat pat) (wrapGenSpan e)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
+import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Arrow
@@ -92,6 +93,8 @@ import GHC.Data.Maybe
import Control.Monad
import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
+
{-
************************************************************************
* *
@@ -267,13 +270,6 @@ tcCheckMonoExpr, tcCheckMonoExprNC
tcCheckMonoExpr expr res_ty = tcMonoLExpr expr (mkCheckExpType res_ty)
tcCheckMonoExprNC expr res_ty = tcMonoLExprNC expr (mkCheckExpType res_ty)
-
--- Expand the HsExpr if it is typechecked after expansions
--- See Note [Handling overloaded and rebindable constructs]
--- See Note [Typechecking by expansion: overview]
-expand_expr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
-expand_expr x = return x
-
---------------
tcMonoLExpr, tcMonoLExprNC
:: LHsExpr GhcRn -- Expression to type check
@@ -282,8 +278,7 @@ tcMonoLExpr, tcMonoLExprNC
-> TcM (LHsExpr GhcTc)
tcMonoLExpr (L loc expr) res_ty
- = do expanded_expr <- expand_expr expr
- addLExprCtxt (locA loc) expanded_expr $ -- Note [Error contexts in generated code]
+ = do addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
@@ -321,7 +316,8 @@ tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
-tcExpr (XExpr e') res_ty = tcXExpr e' res_ty
+tcExpr (XExpr (ExpandedThingRn hse)) res_ty = tcXExpr hse res_ty
+tcExpr e@(XExpr{}) res_ty = tcApp e res_ty
-- Typecheck an occurrence of an unbound Id
--
@@ -562,7 +558,22 @@ tcExpr (HsMultiIf _ alts) res_ty
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
-tcExpr (HsDo _ do_or_lc stmts) res_ty
+tcExpr expr@(HsDo _ do_or_lc stmts) res_ty
+ | DoExpr{} <- do_or_lc
+ -- ApplicativeDo are typechecked using tcDoStmts
+ = do isApplicativeDo <- xoptM LangExt.ApplicativeDo
+ if isApplicativeDo
+ then tcDoStmts do_or_lc stmts res_ty
+ -- Expand expression on the fly otherwise
+ -- See Note [Typechecking by expansion: overview]
+ else do { expr' <- expandDoStmts do_or_lc (unLoc stmts)
+ ; tcLExpr expr' res_ty }
+ | MDoExpr{} <- do_or_lc
+ = do expr' <- expandDoStmts do_or_lc (unLoc stmts)
+ tcExpr expr' res_ty
+ | otherwise
+ --
+
= tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc x pat cmd) res_ty
@@ -678,7 +689,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
; (ds_expr, ds_res_ty, err_msg)
<- expandRecordUpd record_expr possible_parents rbnds res_ty
- ; addExpansionErrCtxt err_msg $
+ ; addErrCtxt err_msg $
do { -- Typecheck the expanded expression.
expr' <- tcExpr ds_expr (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
@@ -776,12 +787,12 @@ directly, it's much easier to
Example: record updates. The typechecker looks like this:
- tcExpr e@(RecordUpd{}) rho = do { ee <- expandExpr e
- ; tcExpr ee rho }
+ tcExpr e@(HsDo{}) rho = do { ee <- expandExpr e
+ ; tcExpr ee rho }
-The `expandExpr` replaces the record update (e { x = rhs })
+The `expandExpr` replaces the HsDo { x <- e1; return x }
with something like
- case e of { MkT a b _ d -> MkT a b rhs d }
+ e1 >>= \ x -> x
and we then typecheck the latter.
See also Note [Handling overloaded and rebindable constructs]
@@ -798,18 +809,23 @@ The rest of this Note explains how that is done.
, xrn_expanded = ee } ))
where `ee` is the expansion of the user written thing `ue`
-* The type checker context has 2 key fields that describe the context:
+* The type checker context has 3 key fields that describe the context:
TcLclCtxt { tcl_loc :: RealSrcSpan
+ , tcl_in_gen_code :: Bool
, tcl_err_ctxt :: [ErrCtxt]
, ... }
Note `tcl_loc` always points to a real place in the source code,
hence `RealSrcSpan`.
The `tcl_err_ctxt` is a stack of contexts, each saying something
- like "In the expression: x+y" or "In the record update: r { x=2 }"
+ like "In the expression: x+y" or "In second argument of `$` namely 'r { x=2 }'"
+
+ The `tcl_in_gen_code` is a boolean that keeps track of whether
+ the current expression being typechecked is compiler generated
+ or user generated.
* Now, when
- tcMonoLHsExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+ tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
gets a located expression, it does 2 things:
* Calls `addLExprCtxt` to perform error context management
* Calls `tcExpr` to typecheck the expression.
@@ -834,16 +850,12 @@ The rest of this Note explains how that is done.
-}
-tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcXExpr (ExpandedThingRn o e) res_ty
+tcXExpr :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcXExpr (HSE o e) res_ty
= mkExpandedTc o <$> -- necessary for hpc ticks
-- Need to call tcExpr and not tcApp
-- as e can be let statement which tcApp cannot gracefully handle
- tcExpr e res_ty
-
--- For record selection, same as HsVar case
-tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
-
+ tcMonoLExpr e res_ty
{-
************************************************************************
@@ -1846,3 +1858,14 @@ checkMissingFields con_like rbinds arg_tys
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
+
+-- Expands the expression on the fly
+-- See Note [Handling overloaded and rebindable constructs]
+-- See Note [Typechecking by expansion: overview]
+tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
+tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts))
+ = do { expanded_expr <- expandDoStmts flav stmts
+ ; return (mkExpandedLExpr orig_expr expanded_expr) }
+
+tcExpandExpr e = return e
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -29,6 +29,8 @@ import GHC.Prelude
import GHC.Hs
import GHC.Hs.Syn.Type
+import GHC.Rename.Utils (mkExpandedTc, mkExpandedExprTc)
+
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
@@ -460,12 +462,12 @@ tcInferAppHead_maybe fun = case fun of
ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty)
HsOverLit _ lit -> Just <$> with_get_ds (tcInferOverLit lit)
XExpr (HsRecSelRn f) -> Just <$> with_get_ds (tcInferRecSelId f)
- XExpr (ExpandedThingRn o e) -> Just <$> (
+ XExpr (ExpandedThingRn (HSE o (L loc e))) -> setSrcSpan (locA loc) $ Just <$> (
-- We do not want to instantiate the type of the head as there may be
-- visible type applications in the argument.
-- c.f. T19167
- (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$>
- tcExprSigma False (errCtxtCtOrigin o) e
+ (\ (e, ds_flag, ty) -> (mkExpandedTc o (L loc e), ds_flag, ty)) <$>
+ tcExprSigma False (errCtxtCtOrigin o) e
)
_ -> return Nothing
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -35,7 +35,7 @@ where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoFRRNC
- , tcMonoLExprNC, tcMonoLExpr, tcExpr
+ , tcMonoLExprNC, tcExpr
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr, tcPolyLExpr )
@@ -44,7 +44,6 @@ import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
-import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
@@ -391,32 +390,14 @@ tcDoStmts MonadComp (L l stmts) res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MonadComp (L l stmts')) }
-tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
-
-tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
- = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
- ; if isApplicativeDo
- then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty doExpr (L l stmts')) }
- else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
- ; traceTc "tcDoStmts" (ppr expanded_expr)
- ; let orig = HsDo noExtField doExpr ss
- ; mkExpandedExprTc orig <$> (
- -- We lose the location on the first statement location in GhcTc, unfortunately.
- -- It is needed for get the pattern match warnings right cf. T14546d
- -- That location is currently recovered from the location stored in OrigStmt
- -- in dsExpr of ExpandedThingTc
- unLoc <$> tcMonoLExpr expanded_expr res_ty)
- }
- }
-tcDoStmts mDoExpr ss@(L _ stmts) res_ty
- = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
- ; let orig = HsDo noExtField mDoExpr ss
- ; e' <- tcMonoLExpr expanded_expr res_ty
- ; return (mkExpandedExprTc orig (unLoc e'))
- }
+tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
+ = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+ ; res_ty <- readExpType res_ty
+ ; return (HsDo res_ty doExpr (L l stmts')) }
+
+-- NB: ghcistmts should fail, MDoExpr is handled by expansions
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody body res_ty
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -625,7 +625,7 @@ exprCtOrigin (HsIf {}) = IfThenElseOrigin
exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p)
exprCtOrigin (RecordUpd{}) = RecordUpdOrigin
exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f))
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = errCtxtCtOrigin o
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
srcCodeOriginCtOrigin :: HsCtxt -> CtOrigin
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -88,7 +88,7 @@ module GHC.Tc.Utils.Monad(
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt,
- addLExprCtxt, addExpansionErrCtxt,
+ addLExprCtxt,
popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
-- * Diagnostic message generation (type checker)
@@ -1089,7 +1089,7 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan loc _) thing_inside
= updLclCtxt (\ctxt -> ctxt {tcl_loc = loc, tcl_in_gen_code = False}) thing_inside
setSrcSpan (GeneratedSrcSpan{}) thing_inside
- = setInGeneratedCode $ thing_inside
+ = updLclCtxt (\ctxt -> ctxt {tcl_in_gen_code = True}) thing_inside
setSrcSpan _ thing_inside
= thing_inside
@@ -1316,11 +1316,16 @@ problem.
Note [Error contexts in generated code]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc`,
- and makes the `ErrCtxStack` a `UserCodeCtxt`
-* it is a no-op otherwise
-So, it's better to do a `setSrcSpan` /before/ `addErrCtxt`.
+* addLExpr updates updates the ErrCtxt stored in LclEnv with the following logic
+ - If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc` to the given value
+ and sets `tcl_in_gen_code` to `False`. Meaning we are not type checking a compiler generated
+ expression. And thus it can add the expression on to the ErrCtxt Stack
+ - If the `SrcSpan` is a GeneratedSrcSpan then `tcl_in_gen_code` is set to `True`, meaning
+ the expression in hand is compiler generated, and hence it is not added on to the stack.
+
+This ensures that the error messages do not leak compiler generated expressions which can
+be confusing to the users.
- See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for
more discussion of this fancy footwork
@@ -1329,33 +1334,32 @@ relation with pattern-match checks
- See Note [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack`
-}
+-- See Note [Error contexts in generated code]
addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
addLExprCtxt lspan e thing_inside
- | not (isGeneratedSrcSpan lspan)
= setSrcSpan lspan $ add_expr_ctxt e thing_inside
- | otherwise -- no op in generated code
- = thing_inside
where
- add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
- add_expr_ctxt e thing_inside
- = case e of
- -- The HsHole special case addresses situations like
- -- f x = _
- -- when we don't want to say "In the expression: _",
- -- because it is mentioned in the error message itself
- HsHole{} -> thing_inside
-
- -- There is a special case for expressions with signatures to avoid having too verbose
- -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
- -- c.f. RecordDotSyntaxFail9
- ExprWithTySig _ (L _ e') _
- | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
-
- -- Flip error ctxt into expansion mode
- XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
-
- _ -> addErrCtxt (ExprCtxt e) thing_inside
-
+ add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+ add_expr_ctxt e thing_inside
+ = do { igc <- inGeneratedCode
+ ; if igc -- generated
+ then thing_inside
+ else case e of
+ -- The HsHole special case addresses situations like
+ -- f x = _
+ -- when we don't want to say "In the expression: _",
+ -- because it is mentioned in the error message itself
+ HsHole{} -> thing_inside
+
+ -- There is a special case for expressions with signatures to avoid having too verbose
+ -- error context. c.f. RecordDotSyntaxFail9
+ -- Add the original HsCtxt if we are typechecking an expanded expression
+ ExprWithTySig _ (L _ e') _
+ | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside
+ XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside
+
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
+ }
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) }
@@ -1369,11 +1373,6 @@ addErrCtxt :: HsCtxt -> TcM a -> TcM a
{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
addErrCtxt ctxt = pushCtxt ctxt
--- See Note [ErrCtxtStack Manipulation]
-addExpansionErrCtxt :: HsCtxt -> TcM a -> TcM a
-{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt]
-addExpansionErrCtxt ctxt thing_inside = setInGeneratedCode $ pushCtxt ctxt thing_inside
-
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -105,7 +105,7 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
-import GHC.Types.SrcLoc (unLoc)
+import GHC.Types.SrcLoc (unLoc, GenLocated (..))
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
@@ -2047,7 +2047,7 @@ getDeepSubsumptionFlag_DataConHead app_head =
go app_head
| XExpr (ConLikeTc (RealDataCon {})) <- app_head
= Deep TopSub
- | XExpr (ExpandedThingTc _ f) <- app_head
+ | XExpr (ExpandedThingTc (HSE _ (L _ f))) <- app_head
= go f
| XExpr (WrapExpr _ f) <- app_head
= go f
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1095,9 +1095,9 @@ zonkExpr (XExpr (WrapExpr co_fn expr))
do new_expr <- zonkExpr expr
return (XExpr (WrapExpr new_co_fn new_expr))
-zonkExpr (XExpr (ExpandedThingTc thing e))
- = do e' <- zonkExpr e
- return $ XExpr (ExpandedThingTc thing e')
+zonkExpr (XExpr (ExpandedThingTc (HSE thing e)))
+ = do e' <- zonkLExpr e
+ return $ XExpr (ExpandedThingTc (HSE thing e'))
zonkExpr e@(XExpr (ConLikeTc {}))
= return e
=====================================
testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
=====================================
@@ -9,6 +9,7 @@ e/E.hs:(15,3)-(15,6): GHC.Internal.Types.Int -> GHC.Internal.Base.String
e/E.hs:(22,3)-(22,6): E.E -> GHC.Internal.Base.String
e/E.hs:(25,3)-(25,10): GHC.Internal.Base.String -> GHC.Internal.Types.IO ()
e/E.hs:(25,12)-(25,37): GHC.Internal.Base.String
+e/E.hs:(25,3)-(25,37): GHC.Internal.Types.IO ()
e/E.hs:(24,16)-(25,37): GHC.Internal.Types.IO ()
e/E.hs:(19,9)-(19,9): E.E
e/E.hs:(5,7)-(5,8): GHC.Internal.Bignum.Integer.Integer
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
=====================================
@@ -18,7 +18,9 @@ RecordDotSyntaxFail11.hs:8:11: error: [GHC-39999]
• No instance for ‘GHC.Internal.Records.HasField "baz" Int a0’
arising from the record selector ‘foo.bar.baz’
NB: ‘Int’ is not a record type.
- • In the expression: (.foo.bar.baz)
- In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
+ • In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
In a stmt of a 'do' block: print $ (.foo.bar.baz) a
+ In the expression:
+ do let a = Foo {foo = ...}
+ print $ (.foo.bar.baz) a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25625e1e23f81193423092ad1f6fbd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25625e1e23f81193423092ad1f6fbd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] make HsExpandedRn and HsExpandedTc payload LExpr,
by Apoorv Ingle (＠ani) 19 Mar '26
by Apoorv Ingle (＠ani) 19 Mar '26
19 Mar '26
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
c056178d by Apoorv Ingle at 2026-03-19T08:58:12-05:00
make HsExpandedRn and HsExpandedTc payload LExpr,
add tcExpand for expanding Do expressions before typechecking in tcExpr
- - - - -
18 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -661,43 +661,23 @@ type instance XXExpr GhcTc = XXExprGhcTc
********************************************************************* -}
data XXExprGhcRn
- = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages
- , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing
- }
+ = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages
+ , xrn_expanded :: LHsExpr GhcRn } -- The compiler generated, expanded thing
+ -- This is located because of do statements (TODO ANI : Add Note)
| HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector
-- See Note [Non-overloaded record field selectors] and
-- Note [Record selectors in the AST]
--- | Build an expression using the extension constructor `XExpr`,
--- and the two components of the expansion: original expression and
--- expanded expressions.
-mkExpandedExpr
- :: HsExpr GhcRn -- ^ source expression context
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = ExprCtxt oExpr
- , xrn_expanded = eExpr })
-
--- | Build an expression using the extension constructor `XExpr`,
--- and the two components of the expansion: original do stmt and
--- expanded expression
-mkExpandedStmt
- :: ExprLStmt GhcRn -- ^ source statement context
- -> HsDoFlavour -- ^ source statements do flavour
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = StmtErrCtxt (HsDoStmt flav) oStmt
- , xrn_expanded = eExpr })
-
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
| ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- { xtc_orig :: HsCtxt -- The original user written thing
- , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
+ { xtc_orig :: HsCtxt -- The original user written thing
+ , xtc_expanded :: LHsExpr GhcTc } -- The expanded typechecked expression
+ -- This is located because of do statements (TODO ANI: Add NOTE)
| ConLikeTc
-- ^ A 'ConLike', either a data constructor or pattern synonym
@@ -722,22 +702,6 @@ data XXExprGhcTc
-- See Note [Non-overloaded record field selectors] and
-- Note [Record selectors in the AST]
-
--- | Build a 'XXExprGhcRn' out of an extension constructor,
--- and the two components of the expansion: original and
--- expanded typechecked expressions.
-mkExpandedExprTc
- :: HsExpr GhcRn -- ^ source expression
- -> HsExpr GhcTc -- ^ expanded typechecked expression
- -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) eExpr
-
-mkExpandedTc
- :: HsCtxt -- ^ source, user written do statement/expression
- -> HsExpr GhcTc -- ^ expanded typechecked expression
- -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedTc o e = XExpr (ExpandedThingTc o e)
-
{- *********************************************************************
* *
Pretty-printing expressions
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -153,7 +153,7 @@ hsExprType (HsQual x _ _) = dataConCantHappen x
hsExprType (HsForAll x _ _) = dataConCantHappen x
hsExprType (HsFunArr x _ _ _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
+hsExprType (XExpr (ExpandedThingTc _ e)) = lhsExprType e
hsExprType (XExpr (ConLikeTc con)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Hs
-- needs to see source types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.ErrCtxt
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Class (lookupHasFieldLabel)
@@ -308,10 +307,7 @@ dsExpr e@(XExpr ext_expr_tc)
WrapExpr {} -> dsApp e
ConLikeTc {} -> dsApp e
- ExpandedThingTc o e
- | StmtErrCtxt _ (L loc _) <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc
- -> putSrcSpanDsA loc $ dsExpr e
- | otherwise -> dsExpr e
+ ExpandedThingTc _ e -> dsLExpr e
-- Hpc Support
HsTick tickish e -> do
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -1167,7 +1167,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =
wrap h h' && exp e e'
exp (XExpr (ExpandedThingTc _ x)) (XExpr (ExpandedThingTc _ x'))
- = exp x x'
+ = lexp x x'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (HsIPVar _ i) (HsIPVar _ i') =
-- the instance for IPName derives using the id, so follow the HsVar case
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1739,7 +1739,7 @@ repE e@(XExpr (ExpandedThingRn o x))
| ExprCtxt e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
- then repE x
+ then repLE x
else repE e }
| otherwise
= notHandled (ThExpressionForm e)
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -492,7 +492,7 @@ isCallSite HsApp{} = True
isCallSite HsAppType{} = True
isCallSite HsCase{} = True
isCallSite (XExpr (ExpandedThingTc _ e))
- = isCallSite e
+ = isCallSite (unLoc e)
-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite _ = False
@@ -660,14 +660,14 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
-addTickHsExpanded :: HsCtxt -> HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpanded :: HsCtxt -> LHsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
-- We always want statements to get a tick, so we can step over each one.
-- To avoid duplicates we blacklist SrcSpans we already inserted here.
StmtErrCtxt _ (L pos _) -> do_tick_black pos
_ -> skip
where
- skip = addTickHsExpr e
+ skip = addTickLHsExpr e
do_tick_black pos = do
d <- getDensity
case d of
@@ -675,9 +675,9 @@ addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
TickForBreakPoints -> tick_it_black pos
_ -> skip
tick_it_black pos =
- unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
+ allocTickBox (ExpBox False) False False (locA pos)
(withBlackListed (locA pos) $
- addTickHsExpr e)
+ addTickHsExpr (unLoc e))
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -757,8 +757,8 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
HsPragE _ _ e -> computeLType e
XExpr (ExpandedThingTc thing e)
| ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax
- -> Just (hsExprType e)
- | otherwise -> computeType e
+ -> Just (lhsExprType e)
+ | otherwise -> computeLType e
XExpr (HsTick _ e) -> computeLType e
XExpr (HsBinTick _ _ e) -> computeLType e
e -> Just (hsExprType e)
@@ -1353,7 +1353,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
ExpandedThingTc _ e
- -> [ toHie (L mspan e) ]
+ -> [ toHie e ]
ConLikeTc con
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
HsTick _ expr
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -24,6 +24,8 @@ module GHC.Rename.Utils (
genSimpleFunBind, genFunBind,
genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet,
+ mkExpandedRn, mkExpandedExpr, mkExpandedStmt, mkExpandedLExpr, mkExpandedTc, mkExpandedExprTc,
+
mkRnSyntaxExpr,
newLocalBndrRn, newLocalBndrsRn,
@@ -45,7 +47,6 @@ import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
--- import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -816,3 +817,50 @@ genSimpleMatch ctxt pats rhs
= wrapGenSpan $
Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats
, m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
+
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original expression and
+-- expanded expressions.
+mkExpandedExpr
+ :: HsExpr GhcRn -- ^ source expression context
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) (wrapGenSpan eExpr)
+
+mkExpandedLExpr
+ :: HsExpr GhcRn -- ^ source expression context
+ -> LHsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedLExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) eExpr
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original do stmt and
+-- expanded expression
+mkExpandedStmt
+ :: ExprLStmt GhcRn -- ^ source statement context
+ -> HsDoFlavour -- ^ source statements do flavour
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedStmt oStmt flav eExpr = mkExpandedRn (StmtErrCtxt (HsDoStmt flav) oStmt) (wrapGenSpan eExpr)
+
+mkExpandedRn
+ :: HsCtxt -- ^ source, user written do statement/expression
+ -> LHsExpr GhcRn -- ^ expanded typechecked expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedRn orig expr = XExpr (ExpandedThingRn orig expr)
+
+-- | Build a 'XXExprGhcRn' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- expanded typechecked expressions.
+mkExpandedExprTc
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) (wrapGenSpan eExpr)
+
+mkExpandedTc
+ :: HsCtxt -- ^ source, user written do statement/expression
+ -> LHsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedTc o e = XExpr (ExpandedThingTc o e)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -957,8 +957,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside
, ppr arg
, ppr arg_no])
; setSrcSpanA arg_loc $
- addNthFunArgErrCtxt app_head arg arg_no $
- thing_inside
+ addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
+ thing_inside
}
| otherwise
= do { traceTc "addArgCtxt" (vcat [text "generated Head"
@@ -969,16 +969,6 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside
; addLExprCtxt (locA arg_loc) arg $
thing_inside
}
- where
- addNthFunArgErrCtxt :: HsExpr GhcRn -> HsExpr GhcRn -> Int -> TcM a -> TcM a
- addNthFunArgErrCtxt app_head arg arg_no thing_inside
- | XExpr (ExpandedThingRn _ _) <- arg
- = addExpansionErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
- thing_inside
- | otherwise
- = addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
- thing_inside
-
{- *********************************************************************
@@ -1947,16 +1937,13 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn
-> Scaled TcRhoType -- Deeply skolemised
-> TcM (HsExprArg 'TcpInst)
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
-quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Scaled _ orig_arg_rho)
+quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
= addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints
-- generated by calls in arg
- do { ((rn_fun_arg, fun_lspan_arg'), rn_args) <- splitHsApps arg
- ; let fun_lspan_arg | null rn_args = locA arg_loc -- arg is an id (or an XExpr) so use the arg_loc in tcInstFun
- | otherwise = fun_lspan_arg'
+ do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
- ; (fun_ue, mb_fun_ty) <- maybe_update_err_ctxt fun_lspan_arg rn_fun_arg $
- (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg)
+ ; (fun_ue, mb_fun_ty) <- (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg)
-- tcCollectingUsage: the use of an Id at the head generates usage-info
-- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must
-- capture and save it in the `EValArgQL`. See (QLA6) in
@@ -2025,20 +2012,6 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
, eaql_res_rho = app_res_rho }) }}}
-maybe_update_err_ctxt :: SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a
-maybe_update_err_ctxt fun_lspan_arg rn_fun_arg thing_inside
- | not (isGeneratedSrcSpan fun_lspan_arg)
- , XExpr (ExpandedThingRn{}) <- rn_fun_arg
- = do igc <- inGeneratedCode
- if igc
- then thing_inside
- else addLExprCtxt fun_lspan_arg rn_fun_arg $
- thing_inside
- | otherwise
- = thing_inside
-
-
-
mk_origin :: SrcSpan -- SrcSpan of the argument
-> HsExpr GhcRn -- The head of the expression application chain
-> TcM CtOrigin
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -14,8 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
- genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Utils
import GHC.Rename.Env ( irrefutableConLikeRn )
import GHC.Tc.Utils.Monad
@@ -114,7 +113,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
-- stmts ~~> stmts'
@@ -122,7 +121,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn t
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ L e_lspan (mkExpandedStmt stmt doFlavour e)
+ [ wrapGenSpan e
, expand_stmts_expr ]
return $ L loc (mkExpandedStmt stmt doFlavour expansion)
@@ -484,4 +483,4 @@ It stores the original statement (with location) and the expanded expression
mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedPatRn pat e = XExpr $ ExpandedThingRn
{ xrn_orig = StmtErrCtxtPat pat
- , xrn_expanded = e}
+ , xrn_expanded = wrapGenSpan e}
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
+import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Arrow
@@ -92,6 +93,8 @@ import GHC.Data.Maybe
import Control.Monad
import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
+
{-
************************************************************************
* *
@@ -267,13 +270,6 @@ tcCheckMonoExpr, tcCheckMonoExprNC
tcCheckMonoExpr expr res_ty = tcMonoLExpr expr (mkCheckExpType res_ty)
tcCheckMonoExprNC expr res_ty = tcMonoLExprNC expr (mkCheckExpType res_ty)
-
--- Expand the HsExpr if it is typechecked after expansions
--- See Note [Handling overloaded and rebindable constructs]
--- See Note [Typechecking by expansion: overview]
-expand_expr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
-expand_expr x = return x
-
---------------
tcMonoLExpr, tcMonoLExprNC
:: LHsExpr GhcRn -- Expression to type check
@@ -282,8 +278,7 @@ tcMonoLExpr, tcMonoLExprNC
-> TcM (LHsExpr GhcTc)
tcMonoLExpr (L loc expr) res_ty
- = do expanded_expr <- expand_expr expr
- addLExprCtxt (locA loc) expanded_expr $ -- Note [Error contexts in generated code]
+ = do addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
@@ -562,7 +557,20 @@ tcExpr (HsMultiIf _ alts) res_ty
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
-tcExpr (HsDo _ do_or_lc stmts) res_ty
+tcExpr expr@(HsDo _ do_or_lc stmts) res_ty
+ | DoExpr{} <- do_or_lc
+ -- ApplicativeDo are typechecked using tcDoStmts
+ = do isApplicativeDo <- xoptM LangExt.ApplicativeDo
+ if isApplicativeDo
+ then tcDoStmts do_or_lc stmts res_ty
+ -- Expand expression on the fly otherwise
+ -- See Note [Typechecking by expansion: overview]
+ else do { expr' <- tcExpandExpr expr
+ ; tcExpr expr' res_ty }
+ | MDoExpr{} <- do_or_lc
+ = do expr' <- tcExpandExpr expr
+ tcExpr expr' res_ty
+ | otherwise
= tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc x pat cmd) res_ty
@@ -678,7 +686,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
; (ds_expr, ds_res_ty, err_msg)
<- expandRecordUpd record_expr possible_parents rbnds res_ty
- ; addExpansionErrCtxt err_msg $
+ ; setInGeneratedCode $ addErrCtxt err_msg $
do { -- Typecheck the expanded expression.
expr' <- tcExpr ds_expr (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
@@ -776,12 +784,12 @@ directly, it's much easier to
Example: record updates. The typechecker looks like this:
- tcExpr e@(RecordUpd{}) rho = do { ee <- expandExpr e
- ; tcExpr ee rho }
+ tcExpr e@(HsDo{}) rho = do { ee <- expandExpr e
+ ; tcExpr ee rho }
-The `expandExpr` replaces the record update (e { x = rhs })
+The `expandExpr` replaces the HsDo { x <- e1; return x }
with something like
- case e of { MkT a b _ d -> MkT a b rhs d }
+ e1 >>= \ x -> x
and we then typecheck the latter.
See also Note [Handling overloaded and rebindable constructs]
@@ -798,8 +806,9 @@ The rest of this Note explains how that is done.
, xrn_expanded = ee } ))
where `ee` is the expansion of the user written thing `ue`
-* The type checker context has 2 key fields that describe the context:
+* The type checker context has 3 key fields that describe the context:
TcLclCtxt { tcl_loc :: RealSrcSpan
+ , tcl_in_gen_code :: Bool
, tcl_err_ctxt :: [ErrCtxt]
, ... }
Note `tcl_loc` always points to a real place in the source code,
@@ -808,8 +817,12 @@ The rest of this Note explains how that is done.
The `tcl_err_ctxt` is a stack of contexts, each saying something
like "In the expression: x+y" or "In the record update: r { x=2 }"
+ The `tcl_in_gen_code` is a boolean that keeps track of whether
+ the current expression being typechecked is compiler generated
+ or user generated.
+
* Now, when
- tcMonoLHsExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+ tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
gets a located expression, it does 2 things:
* Calls `addLExprCtxt` to perform error context management
* Calls `tcExpr` to typecheck the expression.
@@ -839,7 +852,7 @@ tcXExpr (ExpandedThingRn o e) res_ty
= mkExpandedTc o <$> -- necessary for hpc ticks
-- Need to call tcExpr and not tcApp
-- as e can be let statement which tcApp cannot gracefully handle
- tcExpr e res_ty
+ tcMonoLExpr e res_ty
-- For record selection, same as HsVar case
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
@@ -1846,3 +1859,14 @@ checkMissingFields con_like rbinds arg_tys
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
+
+-- Expands the expression on the fly
+-- See Note [Handling overloaded and rebindable constructs]
+-- See Note [Typechecking by expansion: overview]
+tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
+tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts))
+ = do { expanded_expr <- expandDoStmts flav stmts
+ ; return (mkExpandedLExpr orig_expr expanded_expr) }
+
+tcExpandExpr e = return e
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -29,6 +29,8 @@ import GHC.Prelude
import GHC.Hs
import GHC.Hs.Syn.Type
+import GHC.Rename.Utils (mkExpandedTc, mkExpandedExprTc)
+
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
@@ -460,12 +462,12 @@ tcInferAppHead_maybe fun = case fun of
ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty)
HsOverLit _ lit -> Just <$> with_get_ds (tcInferOverLit lit)
XExpr (HsRecSelRn f) -> Just <$> with_get_ds (tcInferRecSelId f)
- XExpr (ExpandedThingRn o e) -> Just <$> (
+ XExpr (ExpandedThingRn o (L loc e)) -> setSrcSpan (locA loc) $ Just <$> (
-- We do not want to instantiate the type of the head as there may be
-- visible type applications in the argument.
-- c.f. T19167
- (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$>
- tcExprSigma False (errCtxtCtOrigin o) e
+ (\ (e, ds_flag, ty) -> (mkExpandedTc o (L loc e), ds_flag, ty)) <$>
+ tcExprSigma False (errCtxtCtOrigin o) e
)
_ -> return Nothing
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -35,7 +35,7 @@ where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoFRRNC
- , tcMonoLExprNC, tcMonoLExpr, tcExpr
+ , tcMonoLExprNC, tcExpr
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr, tcPolyLExpr )
@@ -44,7 +44,6 @@ import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
-import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
@@ -391,32 +390,14 @@ tcDoStmts MonadComp (L l stmts) res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MonadComp (L l stmts')) }
-tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
-
-tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
- = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
- ; if isApplicativeDo
- then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty doExpr (L l stmts')) }
- else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
- ; traceTc "tcDoStmts" (ppr expanded_expr)
- ; let orig = HsDo noExtField doExpr ss
- ; mkExpandedExprTc orig <$> (
- -- We lose the location on the first statement location in GhcTc, unfortunately.
- -- It is needed for get the pattern match warnings right cf. T14546d
- -- That location is currently recovered from the location stored in OrigStmt
- -- in dsExpr of ExpandedThingTc
- unLoc <$> tcMonoLExpr expanded_expr res_ty)
- }
- }
-tcDoStmts mDoExpr ss@(L _ stmts) res_ty
- = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
- ; let orig = HsDo noExtField mDoExpr ss
- ; e' <- tcMonoLExpr expanded_expr res_ty
- ; return (mkExpandedExprTc orig (unLoc e'))
- }
+tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
+ = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+ ; res_ty <- readExpType res_ty
+ ; return (HsDo res_ty doExpr (L l stmts')) }
+
+-- NB: ghcistmts should fail, MDoExpr is handled by expansions
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody body res_ty
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -88,7 +88,7 @@ module GHC.Tc.Utils.Monad(
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt,
- addLExprCtxt, addExpansionErrCtxt,
+ addLExprCtxt,
popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
-- * Diagnostic message generation (type checker)
@@ -1316,11 +1316,16 @@ problem.
Note [Error contexts in generated code]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc`,
- and makes the `ErrCtxStack` a `UserCodeCtxt`
-* it is a no-op otherwise
-So, it's better to do a `setSrcSpan` /before/ `addErrCtxt`.
+* addLExpr updates updates the ErrCtxt stored in LclEnv with the following logic
+ - If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc` to the given value
+ and sets `tcl_in_gen_code` to `False`. Meaning we are not type checking a compiler generated
+ expression. And thus it can add the expression on to the ErrCtxt Stack
+ - If the `SrcSpan` is a GeneratedSrcSpan then `tcl_in_gen_code` is set to `True`, meaning
+ the expression in hand is compiler generated, and hence it is not added on to the stack.
+
+This ensures that the error messages do not leak compiler generated expressions which can
+be confusing to the users.
- See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for
more discussion of this fancy footwork
@@ -1329,33 +1334,32 @@ relation with pattern-match checks
- See Note [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack`
-}
+-- See Note [Error contexts in generated code]
addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
addLExprCtxt lspan e thing_inside
- | not (isGeneratedSrcSpan lspan)
= setSrcSpan lspan $ add_expr_ctxt e thing_inside
- | otherwise -- no op in generated code
- = thing_inside
where
- add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
- add_expr_ctxt e thing_inside
- = case e of
- -- The HsHole special case addresses situations like
- -- f x = _
- -- when we don't want to say "In the expression: _",
- -- because it is mentioned in the error message itself
- HsHole{} -> thing_inside
-
- -- There is a special case for expressions with signatures to avoid having too verbose
- -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
- -- c.f. RecordDotSyntaxFail9
- ExprWithTySig _ (L _ e') _
- | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
-
- -- Flip error ctxt into expansion mode
- XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
-
- _ -> addErrCtxt (ExprCtxt e) thing_inside
-
+ add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+ add_expr_ctxt e thing_inside
+ = do { igc <- inGeneratedCode
+ ; if igc -- generated
+ then thing_inside
+ else case e of
+ -- The HsHole special case addresses situations like
+ -- f x = _
+ -- when we don't want to say "In the expression: _",
+ -- because it is mentioned in the error message itself
+ HsHole{} -> thing_inside
+
+ -- There is a special case for expressions with signatures to avoid having too verbose
+ -- error context. c.f. RecordDotSyntaxFail9
+ -- Add the original HsCtxt if we are typechecking an expanded expression
+ ExprWithTySig _ (L _ e') _
+ | XExpr (ExpandedThingRn o _) <- e' -> addErrCtxt o thing_inside
+ XExpr (ExpandedThingRn o _) -> addErrCtxt o thing_inside
+
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
+ }
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) }
@@ -1369,11 +1373,6 @@ addErrCtxt :: HsCtxt -> TcM a -> TcM a
{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
addErrCtxt ctxt = pushCtxt ctxt
--- See Note [ErrCtxtStack Manipulation]
-addExpansionErrCtxt :: HsCtxt -> TcM a -> TcM a
-{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt]
-addExpansionErrCtxt ctxt thing_inside = setInGeneratedCode $ pushCtxt ctxt thing_inside
-
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -105,7 +105,7 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
-import GHC.Types.SrcLoc (unLoc)
+import GHC.Types.SrcLoc (unLoc, GenLocated (..))
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
@@ -2047,7 +2047,7 @@ getDeepSubsumptionFlag_DataConHead app_head =
go app_head
| XExpr (ConLikeTc (RealDataCon {})) <- app_head
= Deep TopSub
- | XExpr (ExpandedThingTc _ f) <- app_head
+ | XExpr (ExpandedThingTc _ (L _ f)) <- app_head
= go f
| XExpr (WrapExpr _ f) <- app_head
= go f
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1096,7 +1096,7 @@ zonkExpr (XExpr (WrapExpr co_fn expr))
return (XExpr (WrapExpr new_co_fn new_expr))
zonkExpr (XExpr (ExpandedThingTc thing e))
- = do e' <- zonkExpr e
+ = do e' <- zonkLExpr e
return $ XExpr (ExpandedThingTc thing e')
zonkExpr e@(XExpr (ConLikeTc {}))
=====================================
testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
=====================================
@@ -9,6 +9,7 @@ e/E.hs:(15,3)-(15,6): GHC.Internal.Types.Int -> GHC.Internal.Base.String
e/E.hs:(22,3)-(22,6): E.E -> GHC.Internal.Base.String
e/E.hs:(25,3)-(25,10): GHC.Internal.Base.String -> GHC.Internal.Types.IO ()
e/E.hs:(25,12)-(25,37): GHC.Internal.Base.String
+e/E.hs:(25,3)-(25,37): GHC.Internal.Types.IO ()
e/E.hs:(24,16)-(25,37): GHC.Internal.Types.IO ()
e/E.hs:(19,9)-(19,9): E.E
e/E.hs:(5,7)-(5,8): GHC.Internal.Bignum.Integer.Integer
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
=====================================
@@ -18,7 +18,9 @@ RecordDotSyntaxFail11.hs:8:11: error: [GHC-39999]
• No instance for ‘GHC.Internal.Records.HasField "baz" Int a0’
arising from the record selector ‘foo.bar.baz’
NB: ‘Int’ is not a record type.
- • In the expression: (.foo.bar.baz)
- In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
+ • In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
In a stmt of a 'do' block: print $ (.foo.bar.baz) a
+ In the expression:
+ do let a = Foo {foo = ...}
+ print $ (.foo.bar.baz) a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c056178d3cf80e950aaca2a96d38687…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c056178d3cf80e950aaca2a96d38687…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] 3 commits: Record `LinkableUsage` instead of `Linkable` in `LoaderState`
by Hannes Siebenhandl (＠fendor) 19 Mar '26
by Hannes Siebenhandl (＠fendor) 19 Mar '26
19 Mar '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
4439d674 by fendor at 2026-03-19T14:53:03+01:00
Record `LinkableUsage` instead of `Linkable` in `LoaderState`
Retaining a ByteCode `Linkable` after it has been loaded retains its
`UnlinkedBCO`, keeping it alive for the remainder of the program.
This starts accumulating a lot of `UnlinkedBCO` and memory over time.
However, the `Linkable` is merely used to later record its usage in
`mkObjectUsage`, which is used for recompilation checking.
However, this is incorrect, as the interface file and bytecode objects
could be in different states, e.g. the interface changes, but the
bytecode library hasn't changed so we don't need to recompile and vice
versa.
By computing a `Fingerprint` for the `ModuleByteCode`, and recording it
in the `LinkableUsage`, we know precisely whether the `ByteCode` object
on disk is outdated.
Thus, parts of this commit just makes sure that we efficiently compute a
`Fingerprint` for `ModuleByteCode` and store it in the on-disk
representation of `ModuleByteCode`.
We change the `LoaderState` to retain `LinkableUsage`, which is smaller
representation of a `Linkable`. This allows us to free the unneeded
fields of `Linkable` after linking them.
We declare the following memory invariants that this commit implements:
* No `LinkablePart` should be retained from `LoaderState`.
* `Linkable`s should be unloaded after they have been loaded.
These invariants are unfortunately tricky to automatically uphold, so we
are simply documenting our assumptions for now.
We introduce the `linkable-space` test which makes sure that after
loading, no `DotGBC` or `UnlinkedBCO` is retained.
-------------------------
Metric Increase:
MultiLayerModulesTH_OneShot
-------------------------
We allocate a bit more, but the peak number of bytes doesn't change.
While a bit unfortunate, accepting the metric increase.
We add multiple new performance measurements where we were able to
observe the desired memory invariants. Further, we add regression tests
to validate that the recompilation checker behaves more correct than
before.
- - - - -
11ffef7a by fendor at 2026-03-19T14:53:03+01:00
Avoid `panic` during `hscRecompStatus`
- - - - -
f78ea8aa by fendor at 2026-03-19T14:53:03+01:00
Use lazyPut and lazyGet for `OnDiskModuleByteCode` `Binary` instance
- - - - -
25 changed files:
- compiler/GHC/ByteCode/Binary.hs
- + compiler/GHC/ByteCode/Recomp/Binary.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/ghc.cabal.in
- ghc/GHCi/Leak.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Binary.hs
=====================================
@@ -20,7 +20,6 @@ import GHC.Prelude
import GHC.ByteCode.Types
import GHC.Data.FastString
-import GHC.Driver.Env.Types (HscEnv(..))
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.Name.Env
@@ -30,6 +29,7 @@ import GHC.Utils.Binary
import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.Outputable
+import GHC.Utils.Fingerprint (Fingerprint)
import Control.Monad
import Data.Binary qualified as Binary
@@ -47,6 +47,7 @@ import System.IO.Unsafe (unsafeInterleaveIO)
-- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
-- temporary files.
data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module
+ , odgbc_hash :: Fingerprint
, odgbc_compiled_byte_code :: CompiledByteCode
, odgbc_foreign :: [ByteString] -- ^ Contents of object files
}
@@ -94,6 +95,20 @@ instance Binary InterpreterLibraryContents where
putByte bh 1
put_ bh contents
+instance Binary OnDiskModuleByteCode where
+ get bh = do
+ odgbc_hash <- get bh
+ odgbc_module <- get bh
+ odgbc_compiled_byte_code <- lazyGet bh
+ odgbc_foreign <- lazyGet bh
+ pure OnDiskModuleByteCode {..}
+
+ put_ bh OnDiskModuleByteCode {..} = do
+ put_ bh odgbc_hash
+ put_ bh odgbc_module
+ lazyPut bh odgbc_compiled_byte_code
+ lazyPut bh odgbc_foreign
+
instance Binary OnDiskBytecodeLib where
get bh = do
bytecodeLibUnitId <- get bh
@@ -106,18 +121,6 @@ instance Binary OnDiskBytecodeLib where
put_ bh bytecodeLibFiles
put_ bh bytecodeLibForeign
-instance Binary OnDiskModuleByteCode where
- get bh = do
- odgbc_module <- get bh
- odgbc_compiled_byte_code <- get bh
- odgbc_foreign <- get bh
- pure OnDiskModuleByteCode {..}
-
- put_ bh OnDiskModuleByteCode {..} = do
- put_ bh odgbc_module
- put_ bh odgbc_compiled_byte_code
- put_ bh odgbc_foreign
-
instance Binary CompiledByteCode where
get bh = do
bc_bcos <- get bh
@@ -252,8 +255,8 @@ addBinNameWriter bh' = do
Just idx -> (b, idx)
Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
-addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
-addBinNameReader HscEnv {hsc_NC} bh' = do
+addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
+addBinNameReader nc bh' = do
env_ref <- newIORef emptyOccEnv
pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
t <- getByte bh
@@ -266,7 +269,7 @@ addBinNameReader HscEnv {hsc_NC} bh' = do
-- We don't want to get a new unique from the NameCache each time we
-- see a name.
nm' <- unsafeInterleaveIO $ do
- u <- takeUniqFromNameCache hsc_NC
+ u <- takeUniqFromNameCache nc
evaluate $ mkInternalName u occ noSrcSpan
fmap BinName $ atomicModifyIORef' env_ref $ \env ->
case lookupOccEnv env occ of
=====================================
compiler/GHC/ByteCode/Recomp/Binary.hs
=====================================
@@ -0,0 +1,34 @@
+module GHC.ByteCode.Recomp.Binary (
+ -- * Fingerprinting ByteCode objects
+ computeFingerprint,
+) where
+
+import GHC.Prelude
+
+import GHC.ByteCode.Binary (addBinNameWriter)
+import GHC.Iface.Binary
+import GHC.Iface.Recomp.Binary (putNameLiterally, fingerprintBinMem)
+import GHC.Types.Name
+import GHC.Utils.Fingerprint
+import GHC.Utils.Binary
+
+import System.IO.Unsafe
+
+-- | Create a 'Fingerprint' using the appropriate serializers
+-- for 'ModuleByteCode'.
+--
+computeFingerprint :: (Binary a)
+ => (WriteBinHandle -> Name -> IO ())
+ -> a
+ -> Fingerprint
+computeFingerprint put_nonbinding_name a = unsafePerformIO $ do
+ bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
+ bh' <- addBinNameWriter bh
+ putWithUserData QuietBinIFace NormalCompression bh' a
+ fingerprintBinMem bh'
+ where
+ set_user_data bh = setWriterUserData bh $ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter put_nonbinding_name
+ , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally
+ , mkSomeBinaryWriter $ mkWriter putFS
+ ]
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -2,11 +2,11 @@
{-# LANGUAGE RecordWildCards #-}
-- Orphans are here since the Binary instances use an ad-hoc means of serialising
-- names which we don't want to pollute the rest of the codebase with.
-{-# OPTIONS_GHC -Wno-orphans #-}
{- | This module implements the serialization of bytecode objects to and from disk.
-}
module GHC.ByteCode.Serialize
- ( writeBinByteCode, readBinByteCode, ModuleByteCode(..)
+ ( writeBinByteCode, readBinByteCode
+ , ModuleByteCode(..)
, BytecodeLibX(..)
, BytecodeLib
, OnDiskBytecodeLib
@@ -14,26 +14,34 @@ module GHC.ByteCode.Serialize
, InterpreterLibraryContents(..)
, writeBytecodeLib
, readBytecodeLib
+ , mkModuleByteCode
+ , fingerprintModuleByteCodeContents
, decodeOnDiskModuleByteCode
, decodeOnDiskBytecodeLib
)
where
-import Control.Monad
+import GHC.Prelude
+
+import GHC.ByteCode.Binary
+import GHC.ByteCode.Types
+import GHC.ByteCode.Recomp.Binary (computeFingerprint)
import GHC.Driver.Env
+import GHC.Driver.DynFlags
import GHC.Iface.Binary
-import GHC.Prelude
+import GHC.Iface.Recomp.Binary (putNameLiterally)
+import GHC.Linker.Types
+import GHC.Unit.Types
import GHC.Utils.Binary
import GHC.Utils.TmpFs
-import System.FilePath
-import GHC.Driver.DynFlags
-import System.Directory
+import GHC.Utils.Logger
+import GHC.Utils.Fingerprint (Fingerprint)
+
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Traversable
-import GHC.Utils.Logger
-import GHC.Linker.Types
-import GHC.ByteCode.Binary
+import System.Directory
+import System.FilePath
{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -85,7 +93,7 @@ writeBytecodeLib lib path = do
readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib
readBytecodeLib hsc_env path = do
bh' <- readBinMem path
- bh <- addBinNameReader hsc_env bh'
+ bh <- addBinNameReader (hsc_NC hsc_env) bh'
res <- getWithUserData (hsc_NC hsc_env) bh
pure res
@@ -103,7 +111,8 @@ decodeOnDiskModuleByteCode hsc_env odbco = do
pure $ ModuleByteCode {
gbc_module = odgbc_module odbco,
gbc_compiled_byte_code = odgbc_compiled_byte_code odbco,
- gbc_foreign_files = foreign_files
+ gbc_foreign_files = foreign_files,
+ gbc_hash = odgbc_hash odbco
}
decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib
@@ -162,7 +171,8 @@ encodeOnDiskModuleByteCode bco = do
pure $ OnDiskModuleByteCode {
odgbc_module = gbc_module bco,
odgbc_compiled_byte_code = gbc_compiled_byte_code bco,
- odgbc_foreign = foreign_contents
+ odgbc_foreign = foreign_contents,
+ odgbc_hash = gbc_hash bco
}
-- | Read a 'ModuleByteCode' from a file.
@@ -174,7 +184,7 @@ readBinByteCode hsc_env f = do
readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode
readOnDiskModuleByteCode hsc_env f = do
bh' <- readBinMem f
- bh <- addBinNameReader hsc_env bh'
+ bh <- addBinNameReader (hsc_NC hsc_env) bh'
getWithUserData (hsc_NC hsc_env) bh
-- | Write a 'ModuleByteCode' to a file.
@@ -186,3 +196,13 @@ writeBinByteCode f cbc = do
odbco <- encodeOnDiskModuleByteCode cbc
putWithUserData QuietBinIFace NormalCompression bh odbco
writeBinMem bh f
+
+mkModuleByteCode :: Module -> CompiledByteCode -> [FilePath] -> IO ModuleByteCode
+mkModuleByteCode modl cbc foreign_files = do
+ !bcos_hash <- fingerprintModuleByteCodeContents modl cbc foreign_files
+ return $! ModuleByteCode modl cbc foreign_files bcos_hash
+
+fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint
+fingerprintModuleByteCodeContents modl cbc foreign_files = do
+ foreign_contents <- readObjectFiles foreign_files
+ pure $ computeFingerprint putNameLiterally (modl, cbc, foreign_contents)
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -137,7 +137,7 @@ data Hooks = Hooks
, tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
, hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult))
- , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)))
+ , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)))
, ghcPrimIfaceHook :: !(Maybe ModIface)
, runPhaseHook :: !(Maybe PhaseHook)
, runMetaHook :: !(Maybe (MetaHook TcM))
@@ -145,7 +145,7 @@ data Hooks = Hooks
-> HomePackageTable -> IO SuccessFlag))
, runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn)))
, getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type
- -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))
+ -> IO (Either Type (HValue, [LinkableUsage], PkgsLoaded))))
, createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
, stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -297,8 +297,7 @@ import GHC.Cmm.Config (CmmConfig)
import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
-
-import GHC.ByteCode.Serialize
+import qualified GHC.ByteCode.Serialize as ByteCode
{- **********************************************************************
%* *
@@ -973,23 +972,22 @@ checkObjects dflags mb_old_linkable summary = do
-- | Check to see if we can reuse the old linkable, by this point we will
-- have just checked that the old interface matches up with the source hash, so
-- no need to check that again here
-checkByteCodeInMemory :: HscEnv -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
+checkByteCodeInMemory :: HscEnv -> ModSummary -> Maybe (LinkableWith ModuleByteCode) -> IO (MaybeValidated (LinkableWith ModuleByteCode))
checkByteCodeInMemory hsc_env mod_sum mb_old_linkable =
case mb_old_linkable of
Just old_linkable
- | not (linkableIsNativeCodeOnly old_linkable)
-- If `-fwrite-byte-code` is enabled, then check that the .gbc file is
-- up-to-date with the linkable we have in our hand.
-- If ms_bytecode_date is Nothing, then the .gbc file does not exist yet.
-- Otherwise, check that the date matches the linkable date exactly.
- , if gopt Opt_WriteByteCode (hsc_dflags hsc_env)
+ | if gopt Opt_WriteByteCode (hsc_dflags hsc_env)
then maybe False (linkableTime old_linkable ==) (ms_bytecode_date mod_sum)
else True
-> return $ (UpToDateItem old_linkable)
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
-- | Load bytecode from a ".gbc" object file if it exists and is up-to-date
-checkByteCodeFromObject :: HscEnv -> ModSummary -> IO (MaybeValidated Linkable)
+checkByteCodeFromObject :: HscEnv -> ModSummary -> IO (MaybeValidated (LinkableWith ModuleByteCode))
checkByteCodeFromObject hsc_env mod_sum = do
let
obj_fn = ml_bytecode_file (ms_location mod_sum)
@@ -1001,8 +999,8 @@ checkByteCodeFromObject hsc_env mod_sum = do
-- Don't force this if we reuse the linkable already loaded into memory, but we have to check
-- that the one we have on disk would be suitable as well.
linkable <- unsafeInterleaveIO $ do
- bco <- readBinByteCode hsc_env obj_fn
- return $ mkModuleByteCodeLinkable obj_date bco
+ bco <- ByteCode.readBinByteCode hsc_env obj_fn
+ return $ mkOnlyModuleByteCodeLinkable obj_date bco
return $ UpToDateItem linkable
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
@@ -1086,7 +1084,7 @@ loadIfaceByteCodeLazy ::
ModIface ->
ModLocation ->
TypeEnv ->
- IO (Maybe Linkable)
+ IO (Maybe (LinkableWith ModuleByteCode))
loadIfaceByteCodeLazy hsc_env iface location type_env =
case iface_core_bindings iface location of
Nothing -> return Nothing
@@ -1094,8 +1092,9 @@ loadIfaceByteCodeLazy hsc_env iface location type_env =
Just <$> compile wcb
where
compile decls = do
- bco <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls
- linkable $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env decls
+ linkable bco
linkable parts = do
if_time <- modificationTimeIfExists (ml_hi_file_ospath location)
@@ -1136,14 +1135,14 @@ initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
where
type_env = md_types details
- go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
+ go :: RecompBytecodeLinkable -> IO (Maybe (LinkableWith ModuleByteCode))
go (NormalLinkable l) = pure l
go (WholeCoreBindingsLinkable wcbl) =
fmap Just $ for wcbl $ \wcb -> do
add_iface_to_hpt iface details hsc_env
- bco <- unsafeInterleaveIO $
- compileWholeCoreBindings hsc_env type_env wcb
- pure $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env wcb
+ pure bco
-- | Hydrate interface Core bindings and compile them to bytecode.
--
@@ -2205,7 +2204,7 @@ generateAndWriteByteCode hsc_env cgguts mod_location = do
-- See Note [-fwrite-byte-code is not the default]
when (gopt Opt_WriteByteCode dflags) $ do
let bc_path = ml_bytecode_file mod_location
- writeBinByteCode bc_path comp_bc
+ ByteCode.writeBinByteCode bc_path comp_bc
return comp_bc
{-
@@ -2220,20 +2219,20 @@ make user's opt into writing the files.
-}
-- | Generate a 'ModuleByteCode' and write it to disk if `-fwrite-byte-code` is enabled.
-generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Linkable
+generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO (LinkableWith ModuleByteCode)
generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do
bco_object <- generateAndWriteByteCode hsc_env cgguts mod_location
-- Either, get the same time as the .gbc file if it exists, or just the current time.
-- It's important the time of the linkable matches the time of the .gbc file for recompilation
-- checking.
bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file_ospath mod_location)
- return $ mkModuleByteCodeLinkable bco_time bco_object
+ return $ mkOnlyModuleByteCodeLinkable bco_time bco_object
mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode
mkModuleByteCode hsc_env mod mod_location cgguts = do
bcos <- hscGenerateByteCode hsc_env cgguts mod_location
objs <- outputAndCompileForeign hsc_env mod mod_location (cgi_foreign_files cgguts) (cgi_foreign cgguts)
- return $! ModuleByteCode mod bcos objs
+ ByteCode.mkModuleByteCode mod bcos objs
-- | Generate a fresh 'ModuleByteCode' for a given module but do not write it to disk.
generateFreshByteCodeLinkable :: HscEnv
@@ -2755,13 +2754,13 @@ hscTidy hsc_env guts = do
%* *
%********************************************************************* -}
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)
hscCompileCoreExpr hsc_env loc expr =
case hscCompileCoreExprHook (hsc_hooks hsc_env) of
Nothing -> hscCompileCoreExpr' hsc_env loc expr
Just h -> h hsc_env loc expr
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)
hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Simplify it -}
-- Question: should we call SimpleOpt.simpleOptExpr here instead?
@@ -2847,8 +2846,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- load it -}
bco_time <- getCurrentTime
+ mbc <- ByteCode.mkModuleByteCode this_mod bcos []
(mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $
- Linkable bco_time this_mod $ NE.singleton $ DotGBC (ModuleByteCode this_mod bcos [])
+ Linkable bco_time this_mod $ NE.singleton (DotGBC mbc)
-- Get the foreign reference to the name we should have just loaded.
mhvs <- lookupFromLoadedEnv interp (idName binding_id)
{- Get the HValue for the root -}
@@ -2864,7 +2864,7 @@ jsCodeGen
-> Module
-> [(CgStgTopBinding,IdSet)]
-> Id
- -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+ -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)
jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
let logger = hsc_logger hsc_env
tmpfs = hsc_tmpfs hsc_env
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -430,7 +430,7 @@ link' hsc_env batch_attempt_linking mHscMessager hpt
let obj_files = concatMap linkableObjs linkables
in action obj_files
linkBytecodeLinkable action =
- checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeMod_bytecode $ \linkables ->
+ checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeModLinkableByteCode $ \linkables ->
let bytecode = concatMap linkableModuleByteCodes linkables
in action bytecode
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -342,7 +342,7 @@ data Plugins = Plugins
-- The purpose of this field is to cache the plugins so they
-- don't have to be loaded each time they are needed. See
-- 'GHC.Runtime.Loader.initializePlugins'.
- , loadedPluginDeps :: !([Linkable], PkgsLoaded)
+ , loadedPluginDeps :: !([LinkableUsage], PkgsLoaded)
-- ^ The object files required by the loaded plugins
-- See Note [Plugin dependencies]
}
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -7,8 +7,6 @@ module GHC.HsToCore.Usage (
import GHC.Prelude
-import GHC.Driver.Env
-
import GHC.Tc.Types
import GHC.Iface.Load
@@ -27,7 +25,6 @@ import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Unit.Env
-import GHC.Unit.External
import GHC.Unit.Module.Imported
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
@@ -35,18 +32,17 @@ import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import GHC.Data.FastString
-import Data.IORef
import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.List.NonEmpty as NE
import GHC.Linker.Types
import GHC.Unit.Finder
import GHC.Types.Unique.DFM
import GHC.Driver.Plugins
import qualified GHC.Unit.Home.Graph as HUG
+import qualified Data.List.NonEmpty as NE
{- Note [Module self-dependency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -75,19 +71,17 @@ data UsageConfig = UsageConfig
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv
-> Module -> ImportedMods -> [ImportUserSpec] -> NameSet
- -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
+ -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [LinkableUsage] -> PkgsLoaded
-> IfG [Usage]
mkUsageInfo uc plugins fc unit_env
this_mod dir_imp_mods imp_decls used_names
dependent_files dependent_dirs merged needed_links needed_pkgs
= do
- eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))
file_hashes <- liftIO $ mapM getFileHash dependent_files
dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
let hu = ue_unsafeHomeUnit unit_env
- hug = ue_home_unit_graph unit_env
-- Dependencies on object files due to TH and plugins
- object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs
+ object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod
dir_imp_mods imp_decls used_names
@@ -176,44 +170,39 @@ For bytecode objects there are also two forms of dependencies.
1. The existence of the .gbc file for the module you are currently compiling.
2. The usage of bytecode to evaluate TH splices (similar to Note [Object File Dependencies])
-In situation (2), we would ideally want to record the hash of the `CompiledByteCode` which
-was used when evaluating the TH splice. This was a bit tricky to implement so it's tracked as a future
-improvement to the recompilation checking for bytecode objects.
-
-For now, the interface hash is used as a proxy to determine if the BCO will have changed
-for a module or not. This is similar to how the recompilation checking for the legacy
-`-fwrite-if-simplified-core` code path which generated bytecode from core bindings used to work.
-
+In both cases, we record the hash of the 'CompiledByteCode' which was used when evaluating
+the TH splice.
-}
-- | Find object files corresponding to the transitive closure of given home
-- modules and direct object files for pkg dependencies
-mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]
-mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
+mkObjectUsage :: Plugins -> FinderCache -> [LinkableUsage] -> PkgsLoaded -> IO [Usage]
+mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do
let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed)
ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well
(plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
where
- linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)
+ linkableToUsage (Linkable _ _m parts) = traverse partToUsage (NE.toList parts)
msg m = moduleNameString (moduleName m) ++ "[TH] changed"
- fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
+ partToUsage link_usage =
+ case link_usage of
+ FileLinkablePartUsage{flu_file, flu_module} -> do
+ fing (Just $ msg flu_module) flu_file
- partToUsage m part =
- case linkablePartPath part of
- Just fn -> fing (Just (msg m)) fn
- Nothing -> do
- -- This should only happen for home package things but oneshot puts
- -- home package ifaces in the PIT.
- miface <- lookupIfaceByModule hug pit m
- case miface of
- Nothing -> pprPanic "linkableToUsage" (ppr m)
- Just iface ->
- return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface)
+ ByteCodeLinkablePartUsage{bclu_module, bclu_hash} ->
+ pure $
+ UsageHomeModuleBytecode
+ { usg_mod_name = moduleName bclu_module
+ , usg_unit_id = toUnitId $ moduleUnit bclu_module
+ , usg_bytecode_hash = bclu_hash
+ }
+
+ fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
librarySpecToUsage :: LibrarySpec -> IO [Usage]
librarySpecToUsage (Objects os) = traverse (fing Nothing) os
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -88,6 +88,10 @@ import GHC.Iface.Errors.Ppr
import Data.Functor
import Data.Bifunctor (first)
import GHC.Types.PkgQual
+import GHC.ByteCode.Serialize (ModuleByteCode, gbc_hash)
+import GHC.Unit.Home.Graph (lookupHugByModule)
+import GHC.Unit.Home.ModInfo (HomeModLinkable(..), HomeModInfo (..))
+import GHC.Linker.Types (linkableParts)
{-
-----------------------------------------------
@@ -190,6 +194,7 @@ data RecompReason
| ModuleAdded (ImportLevel, UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
+ | ModuleChangedBytecode ModuleName
| FileChanged FilePath
| DirChanged FilePath
| CustomReason String
@@ -224,6 +229,7 @@ instance Outputable RecompReason where
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
ModuleChangedIface m -> ppr m <+> text "changed (interface)"
+ ModuleChangedBytecode m -> ppr m <+> text "changed (bytecode)"
ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
@@ -716,6 +722,15 @@ needInterface mod continue
Nothing -> return $ NeedsRecompile MustCompile
Just iface -> liftIO $ continue iface
+needBytecode :: Module -> (ModuleByteCode -> IO RecompileRequired)
+ -> IfG RecompileRequired
+needBytecode mod continue
+ = do
+ mb_recomp <- tryGetBytecode mod
+ case mb_recomp of
+ Nothing -> return $ NeedsRecompile MustCompile
+ Just mbc -> liftIO $ continue mbc
+
tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface doc_msg mod
= do -- Load the imported interface if possible
@@ -737,6 +752,27 @@ tryGetModIface doc_msg mod
-- import and it's been deleted
Succeeded iface -> pure $ Just iface
+tryGetBytecode :: Module -> IfG (Maybe ModuleByteCode)
+tryGetBytecode mod
+ = do -- Load the imported bytecode if possible
+ logger <- getLogger
+ liftIO $ trace_hi_diffs logger (text "Checking bytecode hash for module" <+> ppr mod <+> ppr (moduleUnit mod))
+
+ mb_module_bytecode <- do
+ env <- getTopEnv
+ liftIO (lookupHugByModule mod (hsc_HUG env)) >>= \ case
+ Nothing -> pure Nothing
+ Just hmi ->
+ case homeMod_bytecode (hm_linkable hmi) of
+ Nothing -> pure Nothing
+ Just gbc_linkable -> pure $ Just $ linkableParts gbc_linkable
+
+ case mb_module_bytecode of
+ Nothing -> do
+ liftIO $ trace_hi_diffs logger (sep [text "Couldn't find bytecode for module", ppr mod])
+ return Nothing
+ Just module_bytecode -> pure $ Just module_bytecode
+
-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
@@ -758,14 +794,14 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha
needInterface mod $ \iface -> do
let reason = ModuleChangedRaw (moduleName mod)
checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)
-checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name
+checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name
, usg_unit_id = uid
- , usg_iface_hash = old_mod_hash } = do
+ , usg_bytecode_hash = old_bytecode_hash } = do
let mod = mkModule (RealUnit (Definite uid)) mod_name
logger <- getLogger
- needInterface mod $ \iface -> do
- let reason = ModuleChangedIface mod_name
- checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface)
+ needBytecode mod $ \cbc -> do
+ let reason = ModuleChangedBytecode mod_name
+ checkBytecodeFingerprint logger reason old_bytecode_hash (gbc_hash cbc)
checkModUsage _ UsageHomeModule{
usg_mod_name = mod_name,
@@ -1030,19 +1066,18 @@ checkModuleFingerprint logger reason old_mod_hash new_mod_hash
= out_of_date_hash logger reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
-checkIfaceFingerprint
+checkBytecodeFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
-checkIfaceFingerprint logger reason old_mod_hash new_mod_hash
- | new_mod_hash == old_mod_hash
- = up_to_date logger (text "Iface fingerprint unchanged")
-
+checkBytecodeFingerprint logger reason old_bytecode_hash new_bytecode_hash
+ | old_bytecode_hash == new_bytecode_hash
+ = up_to_date logger (text "Bytecode fingerprint unchanged")
| otherwise
- = out_of_date_hash logger reason (text " Iface fingerprint has changed")
- old_mod_hash new_mod_hash
+ = out_of_date_hash logger reason (text " Bytecode fingerprint has changed")
+ old_bytecode_hash new_bytecode_hash
------------------------
checkEntityUsage :: Logger
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -146,10 +146,10 @@ pprUsage usage@UsageDirectory{}
ppr (usg_dir_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
-pprUsage usage@UsageHomeModuleInterface{}
- = hsep [text "implementation", ppr (usg_mod_name usage)
+pprUsage usage@UsageHomeModuleBytecode{}
+ = hsep [text "Bytecode", ppr (usg_mod_name usage)
, ppr (usg_unit_id usage)
- , ppr (usg_iface_hash usage)]
+ , ppr (usg_bytecode_hash usage)]
pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc
pprUsageImport mod hash safe
@@ -157,4 +157,4 @@ pprUsageImport mod hash safe
, ppr hash ]
where
pp_safe | safe = text "safe"
- | otherwise = text " -/ "
\ No newline at end of file
+ | otherwise = text " -/ "
=====================================
compiler/GHC/Linker/ByteCode.hs
=====================================
@@ -31,7 +31,7 @@ linkBytecodeLib hsc_env gbcs = do
on_disk_bcos <- mapM (readBinByteCode hsc_env) bytecodeObjects
- let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs <- on_disk_bcos ++ gbcs]
+ let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs _hash <- on_disk_bcos ++ gbcs]
interpreter_foreign_lib <- mkInterpreterLib hsc_env (concat foreign_stubs ++ objectFiles)
@@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files =
return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name)
Nothing -> pure Nothing
False -> do
- pure $ Just (InterpreterStaticObjects files)
\ No newline at end of file
+ pure $ Just (InterpreterStaticObjects files)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -63,7 +63,7 @@ data LinkDepsOpts = LinkDepsOpts
data LinkDeps = LinkDeps
{ ldNeededLinkables :: [Linkable]
- , ldAllLinkables :: [Linkable]
+ , ldAllLinkables :: [LinkableUsage]
, ldUnits :: [UnitId]
, ldNeededUnits :: UniqDSet UnitId
}
@@ -126,7 +126,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
return $ LinkDeps
{ ldNeededLinkables = lnks_needed
- , ldAllLinkables = links_got ++ lnks_needed
+ , ldAllLinkables = links_got ++ mkLinkablesUsage lnks_needed
, ldUnits = pkgs_needed
, ldNeededUnits = pkgs_s
}
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -230,7 +230,7 @@ lookupFromLoadedEnv interp name = do
-- | Load the module containing the given Name and get its associated 'HValue'.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)
loadName interp hsc_env name = do
initLoaderState interp hsc_env
modifyLoaderState interp $ \pls0 -> do
@@ -274,7 +274,7 @@ loadDependencies
-> LoaderState
-> SrcSpan
-> [Module]
- -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
+ -> IO (LoaderState, SuccessFlag, [LinkableUsage], PkgsLoaded) -- ^ returns the set of linkables required
-- When called, the loader state must have been initialized (see `initLoaderState`)
loadDependencies interp hsc_env pls span needed_mods = do
let opts = initLinkDepsOpts hsc_env
@@ -656,7 +656,7 @@ initLinkDepsOpts hsc_env = opts
dflags = hsc_dflags hsc_env
ldLoadByteCode mod locn = do
- bytecode_linkable <- findBytecodeLinkableMaybe hsc_env mod locn
+ bytecode_linkable <- findBytecodeLinkableMaybe hsc_env locn
case bytecode_linkable of
Nothing -> findWholeCoreBindings hsc_env mod
Just bco -> return (Just bco)
@@ -670,19 +670,14 @@ findWholeCoreBindings hsc_env mod = do
sequence (lookupModuleEnv eps_iface_bytecode mod)
-findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable)
-findBytecodeLinkableMaybe hsc_env mod locn = do
+findBytecodeLinkableMaybe :: HscEnv -> ModLocation -> IO (Maybe Linkable)
+findBytecodeLinkableMaybe hsc_env locn = do
let bytecode_fn = ml_bytecode_file locn
bytecode_fn_os = ml_bytecode_file_ospath locn
maybe_bytecode_time <- modificationTimeIfExists bytecode_fn_os
case maybe_bytecode_time of
Nothing -> return Nothing
Just bytecode_time -> do
- -- Also load the interface, for reasons to do with recompilation avoidance.
- -- See Note [Recompilation avoidance with bytecode objects]
- _ <- initIfaceLoad hsc_env $
- loadInterface (text "get_reachable_nodes" <+> parens (ppr mod))
- mod ImportBySystem
bco <- readBinByteCode hsc_env bytecode_fn
return $ Just $ mkModuleByteCodeLinkable bytecode_time bco
@@ -734,7 +729,7 @@ get_reachable_nodes hsc_env mods
********************************************************************* -}
-- | Load the dependencies of a linkable, and then load the linkable itself.
-loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([Linkable], PkgsLoaded)
+loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([LinkableUsage], PkgsLoaded)
loadDecls interp hsc_env span linkable = do
-- Initialise the linker (if it's not been done already)
initLoaderState interp hsc_env
@@ -834,7 +829,7 @@ loadModuleLinkables interp hsc_env pls keep_spec linkables
(objs, bcos) = partitionLinkables linkables
-linkableInSet :: Linkable -> LinkableSet -> Bool
+linkableInSet :: Linkable -> LinkableSet LinkableUsage -> Bool
linkableInSet l objs_loaded =
case lookupModuleEnv objs_loaded (linkableModule l) of
Nothing -> False
@@ -963,17 +958,17 @@ dynLoadObjs interp hsc_env pls objs = do
then addWay WayProf
else id
-rmDupLinkables :: LinkableSet -- Already loaded
- -> [Linkable] -- New linkables
- -> (LinkableSet, -- New loaded set (including new ones)
+rmDupLinkables :: LinkableSet LinkableUsage -- ^ Already loaded
+ -> [Linkable] -- ^ New linkables
+ -> (LinkableSet LinkableUsage, -- New loaded set (including new ones)
[Linkable]) -- New linkables (excluding dups)
rmDupLinkables already ls
= go already [] ls
where
- go already extras [] = (already, extras)
- go already extras (l:ls)
+ go !already extras [] = (already, extras)
+ go !already extras (l:ls)
| linkableInSet l already = go already extras ls
- | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls
+ | otherwise = go (extendModuleEnv already (linkableModule l) $! mkLinkableUsage l) (l:extras) ls
{- **********************************************************************
@@ -1126,7 +1121,7 @@ unload_wkr interp pls@LoaderState{..} = do
-- If we unloaded any object files at all, we need to purge the cache
-- of lookupSymbol results.
- when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $
+ when (not (null (filter (not . null . linkableUsageObjs) linkables_to_unload))) $
purgeLookupSymbolCache interp
let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState,
@@ -1136,7 +1131,7 @@ unload_wkr interp pls@LoaderState{..} = do
return new_pls
where
- unloadObjs :: Linkable -> IO ()
+ unloadObjs :: LinkableUsage -> IO ()
unloadObjs lnk
| interpreterDynamic interp = return ()
-- We don't do any cleanup when linking objects with the
@@ -1144,7 +1139,7 @@ unload_wkr interp pls@LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) (linkableObjs lnk)
+ = mapM_ (unloadObj interp) (linkableUsageObjs lnk)
-- The components of a BCO linkable may contain
-- dot-o files (generated from C stubs).
--
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -49,6 +49,7 @@ module GHC.Linker.Types
, WholeCoreBindingsLinkable
, LinkableWith(..)
, mkModuleByteCodeLinkable
+ , mkOnlyModuleByteCodeLinkable
, LinkablePart(..)
, LinkableObjectSort (..)
, linkableIsNativeCodeOnly
@@ -67,6 +68,11 @@ module GHC.Linker.Types
, linkableFilterNative
, partitionLinkables
+ , LinkableUsage
+ , linkableUsageObjs
+ , mkLinkablesUsage
+ , mkLinkableUsage
+
, ModuleByteCode(..)
)
where
@@ -78,26 +84,29 @@ import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.Message ( LoadedDLL )
+import qualified GHC.Data.OsPath as OsPath
+import qualified GHC.Data.FlatBag as FlatBag
+import GHC.Fingerprint (Fingerprint)
import GHC.Stack.CCS
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, lookupNameEnv )
import GHC.Types.Name ( Name )
import GHC.Types.SptEntry
+import GHC.Types.Unique.DSet
+import GHC.Types.Unique.DFM
+import GHC.Unit.Module.Deps (LinkablePartUsage (..), linkablePartUsageObjectPaths)
+import GHC.Unit.Module.Env
+import GHC.Unit.Module.WholeCoreBindings
import GHC.Utils.Outputable
+import Control.Applicative ((<|>))
import Control.Concurrent.MVar
import Data.Array
+import Data.Functor.Identity
import Data.Time ( UTCTime )
-import GHC.Unit.Module.Env
-import GHC.Types.Unique.DSet
-import GHC.Types.Unique.DFM
-import GHC.Unit.Module.WholeCoreBindings
import Data.Maybe (mapMaybe)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
-import Control.Applicative ((<|>))
-import Data.Functor.Identity
-
{- **********************************************************************
@@ -172,10 +181,10 @@ data LoaderState = LoaderState
-- ^ Information about bytecode objects we have loaded into the
-- interpreter.
- , bcos_loaded :: !LinkableSet
+ , bcos_loaded :: !(LinkableSet LinkableUsage)
-- ^ The currently loaded interpreted modules (home package)
- , objs_loaded :: !LinkableSet
+ , objs_loaded :: !(LinkableSet LinkableUsage)
-- ^ And the currently-loaded compiled modules (home package)
, pkgs_loaded :: !PkgsLoaded
@@ -384,15 +393,17 @@ type Linkable = LinkableWith (NonEmpty LinkablePart)
type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
-type LinkableSet = ModuleEnv Linkable
+type LinkableUsage = LinkableWith (NonEmpty LinkablePartUsage)
-mkLinkableSet :: [Linkable] -> LinkableSet
+type LinkableSet = ModuleEnv
+
+mkLinkableSet :: [Linkable] -> LinkableSet Linkable
mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]
-- | Union of LinkableSets.
--
-- In case of conflict, keep the most recent Linkable (as per linkableTime)
-unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
+unionLinkableSet :: LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a)
unionLinkableSet = plusModuleEnv_C go
where
go l1 l2
@@ -435,8 +446,9 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | DotGBC ModuleByteCode
- -- ^ A byte-code object, lives only in memory.
+ | DotGBC
+ -- ^ A byte-code object, lives only in memory.
+ ModuleByteCode
-- | The in-memory representation of a bytecode object
@@ -444,14 +456,19 @@ data LinkablePart
data ModuleByteCode = ModuleByteCode { gbc_module :: Module
, gbc_compiled_byte_code :: CompiledByteCode
, gbc_foreign_files :: [FilePath] -- ^ Path to object files
+ , gbc_hash :: !Fingerprint
}
mkModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> Linkable
-mkModuleByteCodeLinkable linkable_time bco =
+mkModuleByteCodeLinkable linkable_time bco = do
Linkable linkable_time (gbc_module bco) (pure (DotGBC bco))
+mkOnlyModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> LinkableWith ModuleByteCode
+mkOnlyModuleByteCodeLinkable linkable_time bco = do
+ Linkable linkable_time (gbc_module bco) bco
+
instance Outputable ModuleByteCode where
- ppr (ModuleByteCode mod _cbc _fos) = text "ModuleByteCode" <+> ppr mod
+ ppr (ModuleByteCode mod _cbc _fos _) = text "ModuleByteCode" <+> ppr mod
instance Outputable LinkablePart where
ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort
@@ -544,8 +561,8 @@ linkablePartObjectPaths = \case
-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
linkablePartBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartBCOs = \case
- DotGBC bco -> [gbc_compiled_byte_code bco]
- _ -> []
+ DotGBC bco -> [gbc_compiled_byte_code bco]
+ _ -> []
linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter f linkable = do
@@ -586,6 +603,59 @@ partitionLinkables linkables =
mapMaybe linkableFilterByteCode linkables
)
+-- | Turn a 'Linkable' into a 'LinkableUsage'.
+-- This stores much less information than 'Linkable' and allows us
+-- to free the fields of the 'Linkable'.
+--
+-- Each 'LinkablePartUsage' is fully evaluated to avoid retaining any reference
+-- to the original 'LinkablePart'.
+mkLinkableUsage :: Linkable -> LinkableUsage
+mkLinkableUsage lnk =
+ let
+ linkablesWithUsage = NE.map (go (linkableModule lnk)) (linkableParts lnk)
+ lnkUsage = lnk
+ { linkableParts =
+ -- We force the elements intentionally to whnf.
+ --
+ elemsToWhnf linkablesWithUsage `seq` linkablesWithUsage
+ }
+ in
+ linkableParts lnkUsage `seq` lnkUsage
+ where
+ -- Make sure 'LinkableUsagePart' is evaluated to whnf
+ elemsToWhnf :: NonEmpty a -> ()
+ elemsToWhnf = foldr seq ()
+
+
+ mkFileLinkablePartUsage m fp objs =
+ FileLinkablePartUsage
+ { flu_file = fp
+ , flu_module = m
+ , flu_linkable_objs =
+ FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ mkByteCodeLinkablePartUsage m fp objs =
+ ByteCodeLinkablePartUsage
+ { bclu_module = m
+ , bclu_hash = fp
+ , bclu_linkable_objs =
+ FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ go :: Module -> LinkablePart -> LinkablePartUsage
+ go m lnkPart = case lnkPart of
+ DotO fn _ -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart)
+ DotA fn -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart)
+ DotDLL fn -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart)
+ DotGBC mbc -> mkByteCodeLinkablePartUsage m (gbc_hash mbc) (linkablePartObjectPaths lnkPart)
+
+mkLinkablesUsage :: [Linkable] -> [LinkableUsage]
+mkLinkablesUsage linkables = map mkLinkableUsage linkables
+
+linkableUsageObjs :: LinkableUsage -> [FilePath]
+linkableUsageObjs lnkWithUsage = concatMap linkablePartUsageObjectPaths (linkableParts lnkWithUsage)
+
{- **********************************************************************
Loading packages
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -153,7 +153,7 @@ initializePlugins hsc_env
([] , _ ) -> False -- some external plugin added
(p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss
-loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [LinkableUsage], PkgsLoaded)
loadPlugins hsc_env
= do { unless (null to_load) $
checkExternalInterpreter hsc_env
@@ -173,7 +173,7 @@ loadPlugins hsc_env
loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env
-loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [LinkableUsage], PkgsLoaded)
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
(plugin, _iface, links, pkgs)
@@ -188,7 +188,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
-> throwIO (InstallationError "Plugins require -fno-external-interpreter")
_ -> pure ()
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableUsage], PkgsLoaded)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
@@ -266,7 +266,7 @@ forceLoadTyCon hsc_env con_name = do
-- * If the Name does not exist in the module
-- * If the link failed
-getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [LinkableUsage], PkgsLoaded))
getValueSafely hsc_env val_name expected_type = do
eith_hval <- case getValueSafelyHook hooks of
Nothing -> getHValueSafely interp hsc_env val_name expected_type
@@ -281,7 +281,7 @@ getValueSafely hsc_env val_name expected_type = do
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
-getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [LinkableUsage], PkgsLoaded))
getHValueSafely interp hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-- Now look up the names for the value and type constructor in the type environment
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -562,7 +562,7 @@ data TcGblEnv
-- is implicit rather than explicit, so we have to zap a
-- mutable variable.
- tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded),
+ tcg_th_needed_deps :: TcRef ([LinkableUsage], PkgsLoaded),
-- ^ The set of runtime dependencies required by this module
-- See Note [Object File Dependencies]
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2259,7 +2259,7 @@ fillCoercionHole (CH { ch_ref = ref, ch_co_var = cv }) co
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
-recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
+recordThNeededRuntimeDeps :: [LinkableUsage] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps new_links new_pkgs
= do { env <- getGblEnv
; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -3,9 +3,11 @@
module GHC.Unit.Home.ModInfo
(
HomeModInfo (..)
- , HomeModLinkable (..)
, homeModInfoObject
, homeModInfoByteCode
+ , HomeModLinkable (..)
+ , homeModLinkableByteCode
+ , homeModLinkableObject
, emptyHomeModInfoLinkable
)
where
@@ -15,9 +17,10 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Linker.Types ( Linkable )
+import GHC.Linker.Types ( Linkable, LinkableWith, ModuleByteCode, LinkablePart (..) )
import GHC.Utils.Outputable
+import qualified Data.List.NonEmpty as NE
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -48,18 +51,24 @@ data HomeModInfo = HomeModInfo
}
homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
-homeModInfoByteCode = homeMod_bytecode . hm_linkable
+homeModInfoByteCode = homeModLinkableByteCode . hm_linkable
homeModInfoObject :: HomeModInfo -> Maybe Linkable
-homeModInfoObject = homeMod_object . hm_linkable
+homeModInfoObject = homeModLinkableObject . hm_linkable
emptyHomeModInfoLinkable :: HomeModLinkable
emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
-- See Note [Home module build products]
-data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe (LinkableWith ModuleByteCode))
, homeMod_object :: !(Maybe Linkable) }
+homeModLinkableByteCode :: HomeModLinkable -> Maybe Linkable
+homeModLinkableByteCode = fmap (fmap (NE.singleton . DotGBC)) . homeMod_bytecode
+
+homeModLinkableObject :: HomeModLinkable -> Maybe Linkable
+homeModLinkableObject = homeMod_object
+
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -22,16 +22,22 @@ module GHC.Unit.Module.Deps
, ImportAvails (..)
, IfaceImportLevel(..)
, tcImportLevel
+ , LinkablePartUsage(..)
+ , linkablePartUsageObjectPaths
)
where
import GHC.Prelude
import GHC.Data.FastString
+import GHC.Data.FlatBag
+import GHC.Data.OsPath
+import qualified GHC.Data.OsPath as OsPath
import GHC.Types.Avail
import GHC.Types.SafeHaskell
import GHC.Types.Name
+import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Unit.Module.Imported
@@ -43,13 +49,12 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable
+import Control.DeepSeq
+import Data.Bifunctor
+import qualified Data.Foldable as Foldable
import Data.List (sortBy, sort, partition)
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.Bifunctor
-import Control.DeepSeq
-import GHC.Types.Name.Set
-
-- | Dependency information about ALL modules and packages below this one
@@ -372,12 +377,12 @@ data Usage
-- we won't spot it here. If you do want to spot that, the caller
-- should recursively add them to their useage.
}
- | UsageHomeModuleInterface {
+ | UsageHomeModuleBytecode {
usg_mod_name :: ModuleName
-- ^ Name of the module
, usg_unit_id :: UnitId
-- ^ UnitId of the HomeUnit the module is from
- , usg_iface_hash :: Fingerprint
+ , usg_bytecode_hash :: Fingerprint
-- ^ The *interface* hash of the module, not the ABI hash.
-- This changes when anything about the interface (and hence the
-- module) has changed.
@@ -412,7 +417,7 @@ instance NFData Usage where
rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
- rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
+ rnf (UsageHomeModuleBytecode mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
instance Binary Usage where
put_ bh usg@UsagePackageModule{} = do
@@ -441,11 +446,11 @@ instance Binary Usage where
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
- put_ bh usg@UsageHomeModuleInterface{} = do
+ put_ bh usg@UsageHomeModuleBytecode{} = do
putByte bh 4
put_ bh (usg_mod_name usg)
put_ bh (usg_unit_id usg)
- put_ bh (usg_iface_hash usg)
+ put_ bh (usg_bytecode_hash usg)
put_ bh usg@UsageDirectory{} = do
putByte bh 5
@@ -483,7 +488,7 @@ instance Binary Usage where
mod <- get bh
uid <- get bh
hash <- get bh
- return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
+ return UsageHomeModuleBytecode { usg_mod_name = mod, usg_unit_id = uid, usg_bytecode_hash = hash }
5 -> do
dp <- get bh
hash <- get bh
@@ -695,3 +700,33 @@ data ImportAvails
-- ^ Family instance modules below us in the import tree (and maybe
-- including us for imported modules)
}
+
+-- | Record usage of a 'LinkablePart'.
+data LinkablePartUsage
+ = FileLinkablePartUsage
+ { flu_file :: !FilePath
+ , flu_module :: !Module
+ , flu_linkable_objs :: !(FlatBag OsPath)
+ }
+ | ByteCodeLinkablePartUsage
+ { bclu_module :: !Module
+ , bclu_hash :: !Fingerprint
+ , bclu_linkable_objs :: !(FlatBag OsPath)
+ }
+
+instance Outputable LinkablePartUsage where
+ ppr = \ case
+ FileLinkablePartUsage fp modl _objs ->
+ text "FileLinkableUsage" <+> text fp <+> ppr modl
+
+ ByteCodeLinkablePartUsage modl hash _objs ->
+ text "ByteCodeLinkableUsage" <+> ppr modl <+> ppr hash
+
+linkablePartUsageObjectPaths :: LinkablePartUsage -> [FilePath]
+linkablePartUsageObjectPaths lnkUsage =
+ map OsPath.unsafeDecodeUtf . Foldable.toList $ linkableUsageObjectOsPaths lnkUsage
+
+linkableUsageObjectOsPaths :: LinkablePartUsage -> FlatBag OsPath
+linkableUsageObjectOsPaths lnkUsage = case lnkUsage of
+ FileLinkablePartUsage{flu_linkable_objs} -> flu_linkable_objs
+ ByteCodeLinkablePartUsage{bclu_linkable_objs} -> bclu_linkable_objs
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
-import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
@@ -59,7 +59,7 @@ data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompByte
, recompLinkables_object :: !(Maybe Linkable) }
data RecompBytecodeLinkable
- = NormalLinkable !(Maybe Linkable)
+ = NormalLinkable !(Maybe (LinkableWith ModuleByteCode))
| WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
instance Outputable HscRecompStatus where
@@ -83,11 +83,9 @@ emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing
safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o
-justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
+justBytecode :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable -> RecompLinkables
justBytecode = \case
- Left lm ->
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ Left lm -> emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -95,10 +93,10 @@ justObjects lm =
assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
$ emptyRecompLinkables { recompLinkables_object = Just lm }
-bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
+bytecodeAndObjects :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
bytecodeAndObjects either_bc o = case either_bc of
Left bc ->
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (NormalLinkable (Just bc)) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -215,6 +215,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Recomp.Binary
GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -52,8 +52,11 @@ getLeakIndicators hsc_env =
return $ LeakModIndicators{..}
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
- mkWeakLinkables (HomeModLinkable mbc mo) =
- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
+ mkWeakLinkables hml =
+ mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln)
+ [ homeModLinkableByteCode hml
+ , homeModLinkableObject hml
+ ]
-- | Look at the LeakIndicators collected by an earlier call to
-- `getLeakIndicators`, and print messasges if any of them are still
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -60,6 +60,7 @@ GHC.Data.FastMutInt
GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
+GHC.Data.FlatBag
GHC.Data.Graph.Directed
GHC.Data.Graph.Directed.Internal
GHC.Data.Graph.UnVar
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -61,6 +61,7 @@ GHC.Data.FastMutInt
GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
+GHC.Data.FlatBag
GHC.Data.Graph.Directed
GHC.Data.Graph.Directed.Internal
GHC.Data.Graph.Directed.Reachability
=====================================
testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout
=====================================
@@ -3,6 +3,6 @@ GHCi, version 9.15.20260122: https://www.haskell.org/ghc/ :? for help
[2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp]
Ok, two modules loaded.
ghci> ghci> ghci> [1 of 2] Compiling Dep ( Dep.hs, interpreted )[dep] [Source file changed]
-[2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp] [Dep changed (interface)]
+[2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp] [Dep changed (bytecode)]
Ok, two modules reloaded.
ghci> Leaving GHCi.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/48a1e6e897a6ea60da3be0a2900018…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/48a1e6e897a6ea60da3be0a2900018…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] 4 commits: Add linkable testsuite
by Hannes Siebenhandl (＠fendor) 19 Mar '26
by Hannes Siebenhandl (＠fendor) 19 Mar '26
19 Mar '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
4af94005 by fendor at 2026-03-19T14:41:49+01:00
Add linkable testsuite
- - - - -
6859885a by fendor at 2026-03-19T14:41:49+01:00
Extract Binary instances to `GHC.ByteCode.Binary`
- - - - -
4ce6773e by fendor at 2026-03-19T14:41:49+01:00
Record `LinkableUsage` instead of `Linkable` in `LoaderState`
Retaining a ByteCode `Linkable` after it has been loaded retains its
`UnlinkedBCO`, keeping it alive for the remainder of the program.
This starts accumulating a lot of `UnlinkedBCO` and memory over time.
However, the `Linkable` is merely used to later record its usage in
`mkObjectUsage`, which is used for recompilation checking.
However, this is incorrect, as the interface file and bytecode objects
could be in different states, e.g. the interface changes, but the
bytecode library hasn't changed so we don't need to recompile and vice
versa.
By computing a `Fingerprint` for the `ModuleByteCode`, and recording it
in the `LinkableUsage`, we know precisely whether the `ByteCode` object
on disk is outdated.
Thus, parts of this commit just makes sure that we efficiently compute a
`Fingerprint` for `ModuleByteCode` and store it in the on-disk
representation of `ModuleByteCode`.
We change the `LoaderState` to retain `LinkableUsage`, which is smaller
representation of a `Linkable`. This allows us to free the unneeded
fields of `Linkable` after linking them.
We declare the following memory invariants that this commit implements:
* No `LinkablePart` should be retained from `LoaderState`.
* `Linkable`s should be unloaded after they have been loaded.
These invariants are unfortunately tricky to automatically uphold, so we
are simply documenting our assumptions for now.
We introduce the `linkable-space` test which makes sure that after
loading, no `DotGBC` or `UnlinkedBCO` is retained.
-------------------------
Metric Increase:
MultiLayerModulesTH_OneShot
-------------------------
We allocate a bit more, but the peak number of bytes doesn't change.
While a bit unfortunate, accepting the metric increase.
We add multiple new performance measurements where we were able to
observe the desired memory invariants. Further, we add regression tests
to validate that the recompilation checker behaves more correct than
before.
- - - - -
48a1e6e8 by fendor at 2026-03-19T14:41:49+01:00
Avoid `panic` during `hscRecompStatus`
- - - - -
42 changed files:
- + compiler/GHC/ByteCode/Binary.hs
- + compiler/GHC/ByteCode/Recomp/Binary.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/ghc.cabal.in
- ghc/GHCi/Leak.hs
- + testsuite/tests/bytecode/TLinkable/BCOTemplate.hs
- + testsuite/tests/bytecode/TLinkable/LinkableUsage01.stderr
- + testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr
- + testsuite/tests/bytecode/TLinkable/Makefile
- + testsuite/tests/bytecode/TLinkable/all.T
- + testsuite/tests/bytecode/TLinkable/genLinkables.sh
- + testsuite/tests/bytecode/TLinkable/linkable-space.hs
- + testsuite/tests/bytecode/TLinkable/linkable-space.stdout
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout
- + testsuite/tests/driver/recomp022/A1.hs
- + testsuite/tests/driver/recomp022/A2.hs
- + testsuite/tests/driver/recomp022/A3.hs
- + testsuite/tests/driver/recomp022/B.hs
- + testsuite/tests/driver/recomp022/C.hs
- + testsuite/tests/driver/recomp022/Makefile
- + testsuite/tests/driver/recomp022/all.T
- + testsuite/tests/driver/recomp022/recomp022a.stdout
- + testsuite/tests/driver/recomp022/recomp022b.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6656b28940377c83fbb0f5e292eb9d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6656b28940377c83fbb0f5e292eb9d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 17 commits: ghci: Mention active language edition in startup banner
by Marge Bot (＠marge-bot) 19 Mar '26
by Marge Bot (＠marge-bot) 19 Mar '26
19 Mar '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4354218f by Adam Gundry at 2026-03-19T08:23:57-04:00
ghci: Mention active language edition in startup banner
Per GHC proposal 632, this makes the GHCi startup banner include
the active language edition, plus an indication of whether this
was the default (as opposed to being explicitly selected via an
option such as `-XGHC2024`). For example:
```
$ ghci
GHCi, version 9.14.1: https://www.haskell.org/ghc/ :? for help
Using default language edition: GHC2024
ghci>
```
Fixes #26037.
- - - - -
04895566 by Sylvain Henry at 2026-03-19T08:24:26-04:00
Check that shift values are valid
In GHC's codebase in non-DEBUG builds we silently substitute shiftL/R
with unsafeShiftL/R for performance reasons. However we were not
checking that the shift value was valid for unsafeShiftL/R, leading to
wrong computations, but only in non-DEBUG builds.
This patch adds the necessary checks and reports an error when a wrong
shift value is passed.
- - - - -
2b5a4872 by Sylvain Henry at 2026-03-19T08:24:26-04:00
Implement basic value range analysis (#25718)
Perform basic value range analysis to try to determine at compile time
the result of the application of some comparison primops (ltWord#, etc.).
This subsumes the built-in rewrite rules used previously to check if one
of the comparison argument was a bound (e.g. (x :: Word8) <= 255 is
always True). Our analysis is more powerful and handles type
conversions: e.g. word8ToWord x <= 255 is now detected as always True too.
We also use value range analysis to filter unreachable alternatives in
case-expressions. To support this, we had to allow case-expressions for
primitive types to not have a DEFAULT alternative (as was assumed before
and checked in Core lint).
- - - - -
26e6a745 by sheaf at 2026-03-19T08:24:43-04:00
Improve incomplete record selector warnings
This commit stops GHC from emitting spurious incomplete record selector
warnings for bare selectors/projections such as .fld
There are two places we currently emit incomplete record selector
warnings:
1. In the desugarer, when we see a record selector or an occurrence
of 'getField'. Here, we can use pattern matching information to
ensure we don't give false positives.
2. In the typechecker, which might sometimes give false positives but
can emit warnings in cases that the pattern match checker would
otherwise miss.
This is explained in Note [Detecting incomplete record selectors]
in GHC.HsToCore.Pmc.
Now, we obviously don't want to emit the same error twice, and generally
we prefer (1), as those messages contain fewer false positives. So we
suppress (2) when we are sure we are going to emit (1); the logic for
doing so is in GHC.Tc.Instance.Class.warnIncompleteRecSel,
and works by looking at the CtOrigin.
Now, the issue was that this logic handled explicit record selectors as
well as overloaded record field selectors such as "x.r" (which turns
into a simple GetFieldOrigin CtOrigin), but it didn't properly handle
record projectors like ".fld" or ".fld1.fld2" (which result in other
CtOrigins such as 'RecordFieldProjectionOrigin').
To solve this problem, we re-use the 'isHasFieldOrigin' introduced in
fbdc623a (slightly adjusted).
On the way, we also had to update the desugarer with special handling
for the 'ExpandedThingTc' case in 'ds_app', to make sure that
'ds_app_var' sees all the type arguments to 'getField' in order for it
to indeed emit warnings like in (1).
Fixes #26686
- - - - -
6ead1bbf by Cheng Shao at 2026-03-19T08:24:45-04:00
rts: opportunistically grow the MutableByteArray# in-place in resizeMutableByteArray#
Following !15234, this patch improves `resizeMutableByteArray#` memory
efficiency by growing the `MutableByteArray#` in-place if possible,
addressing an old todo comment here. Also adds a new test case
`resizeMutableByteArrayInPlace` that stresses this behavior.
- - - - -
4b1ff14e by Zubin Duggal at 2026-03-19T08:24:46-04:00
compiler/ffi: Collapse void pointer chains in capi wrappers
New gcc/clang treat -Wincompatible-pointer-types as an error by
default. Since C only allows implicit conversion from void*, not void**,
capi wrappers for functions taking e.g. abstract** would fail to compile
when the Haskell type Ptr (Ptr Abstract) was naively translated to void**.
Collapse nested void pointers to a single void* when the pointee type
has no known C representation.
Fixes #26852
- - - - -
c0b5e874 by Teo Camarasu at 2026-03-19T08:24:47-04:00
ghc-internal: Float Generics to near top of module graph
We remove GHC.Internal.Generics from the critical path of the
`ghc-internal` module graph. GHC.Internal.Generics used to be in the
middle of the module graph, but now it is nearer the top (built later).
This change thins out the module graph and allows us to get rid of the
ByteOrder hs-boot file.
We implement this by moving Generics instances from the module where the
datatype is defined to the GHC.Internal.Generics module. This trades off
increasing the compiled size of GHC.Internal.Generics with reducing the
dependency footprint of datatype modules.
Not all instances are moved to GHC.Internal.Generics. For instance,
`GHC.Internal.Control.Monad.Fix` keeps its instance as it is one of the
very last modules compiled in `ghc-internal` and so inverting the
relationship here would risk adding GHC.Internal.Generics back onto the
critical path.
We also don't change modules that are re-exported from the `template-haskell` or `ghc-heap`.
This is done to make it easy to eventually move `Generics` to `base`
once something like #26657 is implemented.
Resolves #26930
Metric Decrease:
T21839c
- - - - -
511afa7e by Luite Stegeman at 2026-03-19T08:25:01-04:00
Move some functions related to pointer tagging to a separate module
- - - - -
316ec094 by Luite Stegeman at 2026-03-19T08:25:01-04:00
Branchless unpacking for enumeration types
Change unpacking for enumeration types to go to Word8#/Word16#/Word#
directly instead of going through an intermediate unboxed sum. This
allows us to do a branchless conversion using DataToTag and TagToEnum.
Fixes #26970
- - - - -
14aad09b by Luite Stegeman at 2026-03-19T08:25:06-04:00
bytecode: Carefully SLIDE off the end of a stack chunk
The SLIDE bytecode instruction was not checking for stack chunk
boundaries and could corrupt the stack underflow frame, leading
to crashes.
We add a check to use safe writes if we cross the chunk boundary
and also handle stack underflow if Sp is advanced past the underflow
frame.
fix #27001
- - - - -
e1e03d27 by Cheng Shao at 2026-03-19T08:25:07-04:00
ghci: serialize BCOByteArray buffer directly when possible
This patch changes the `Binary` instances of `BCOByteArray` to
directly serialize the underlying buffer when possible, while also
taking into account the issue of host-dependent `Word` width. See
added comments and amended `Note [BCOByteArray serialization]` for
detailed explanation. Closes #27020.
- - - - -
eaa9beaa by Matthew Pickering at 2026-03-19T08:25:15-04:00
Use OsPath rather than FilePath in Downsweep cache
This gets us one step closure to uniformly using `OsPath` in the
compiler.
- - - - -
93de2b51 by Cheng Shao at 2026-03-19T08:25:17-04:00
hadrian: fix ghc-in-ghci flavour stage0 shared libraries
This patch fixes missing stage0 shared libraries in hadrian
ghc-in-ghci flavour, which was accidentally dropped in
669d09f950a6e88b903d9fd8a7571531774d4d5d and resulted in a regression
in HLS support on linux/macos. Fixes #27057.
- - - - -
fea35103 by Cheng Shao at 2026-03-19T08:25:17-04:00
ghc-internal: fix unused imports again
Fixes #27059.
- - - - -
54456a53 by Sylvain Henry at 2026-03-19T08:25:23-04:00
JS: install rts/Types.h header file (#27033)
It was an omission, making HsFFI.h not usable with GHC using the JS
backend.
- - - - -
b9918009 by Cheng Shao at 2026-03-19T08:25:25-04:00
hadrian: don't compile RTS with -Winline
This patch removes `-Winline` from cflags when compiling the RTS,
given that:
1. It generates a huge pile of spam and hurts developer experience
2. Whether inlining happens is highly dependent on toolchains,
flavours, etc, and it's not really an issue to fix if inlining
doesn't happen; it's a hint to the C compiler anyway.
Fixes #27060.
- - - - -
f55d53f3 by Cheng Shao at 2026-03-19T08:25:25-04:00
hadrian: compile libffi-clib with -Wno-deprecated-declarations
This patch adds `-Wno-deprecated-declarations` to cflags of
`libffi-clib`, given that it produces noise at compile-time that
aren't really our issue to fix anyway, it's from vendored libffi
source code.
- - - - -
93 changed files:
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- + compiler/GHC/Core/Opt/Range.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Pmc.hs
- + compiler/GHC/Platform/Tag.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Flavours/GhcInGhci.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs
- − libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Char.hs
- libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs
- libraries/ghc-internal/src/GHC/Internal/Generics.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc
- libraries/ghc-internal/src/GHC/Internal/Read.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TopHandler.hs
- libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs
- libraries/ghci/GHCi/ResolvedBCO.hs
- rts/Interpreter.c
- rts/PrimOps.cmm
- rts/rts.cabal
- + testsuite/tests/bytecode/T27001.hs
- + testsuite/tests/bytecode/T27001.stdout
- testsuite/tests/bytecode/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/ffi/should_compile/T26852.h
- + testsuite/tests/ffi/should_compile/T26852.hs
- + testsuite/tests/ffi/should_compile/T26852.stderr
- testsuite/tests/ffi/should_compile/all.T
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T10963.stderr
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/ghci/should_run/BinaryArray.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/javascript/js-c-sources/T27033.hs
- + testsuite/tests/javascript/js-c-sources/T27033.stdout
- + testsuite/tests/javascript/js-c-sources/T27033_c.c
- + testsuite/tests/javascript/js-c-sources/T27033_js.js
- testsuite/tests/javascript/js-c-sources/all.T
- + testsuite/tests/overloadedrecflds/should_compile/T26686.hs
- + testsuite/tests/overloadedrecflds/should_compile/T26686.stderr
- testsuite/tests/overloadedrecflds/should_compile/all.T
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/resizeMutableByteArrayInPlace.hs
- + testsuite/tests/simplCore/should_compile/T19166.hs
- + testsuite/tests/simplCore/should_compile/T19166.stderr
- + testsuite/tests/simplCore/should_compile/T25718.hs
- + testsuite/tests/simplCore/should_compile/T25718.stderr
- + testsuite/tests/simplCore/should_compile/T25718a.hs
- + testsuite/tests/simplCore/should_compile/T25718a.stderr
- + testsuite/tests/simplCore/should_compile/T25718b.hs
- + testsuite/tests/simplCore/should_compile/T25718b.stderr
- + testsuite/tests/simplCore/should_compile/T25718c.hs
- + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32
- + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplStg/should_run/all.T
- + testsuite/tests/simplStg/should_run/unpack_enum.hs
- + testsuite/tests/simplStg/should_run/unpack_enum.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c257675b243e9d28ef0cf94fee8a29…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c257675b243e9d28ef0cf94fee8a29…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
19 Mar '26
Simon Jakobi pushed new branch wip/sjakobi/T16145 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T16145
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/decode-stack-with-ipe] Expose decodeStackWithIpe from ghc-experimental
by Rodrigo Mesquita (＠alt-romes) 19 Mar '26
by Rodrigo Mesquita (＠alt-romes) 19 Mar '26
19 Mar '26
Rodrigo Mesquita pushed to branch wip/romes/decode-stack-with-ipe at Glasgow Haskell Compiler / GHC
Commits:
56e45f1b by Rodrigo Mesquita at 2026-03-19T11:46:14+00:00
Expose decodeStackWithIpe from ghc-experimental
This decoding is useful to the debugger and it wasn't originally
exported as an oversight.
- - - - -
4 changed files:
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/GHC/Stack/Decode/Experimental.hs
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -41,6 +41,7 @@ library
GHC.TypeNats.Experimental
GHC.RTS.Flags.Experimental
GHC.Stack.Annotation.Experimental
+ GHC.Stack.Decode.Experimental
GHC.Stats.Experimental
Prelude.Experimental
System.Mem.Experimental
=====================================
libraries/ghc-experimental/src/GHC/Stack/Decode/Experimental.hs
=====================================
@@ -0,0 +1,13 @@
+module GHC.Stack.Decode.Experimental (
+ -- * High-level stack decoders
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackFrameWithIpe,
+ prettyStackEntry,
+ ) where
+
+import GHC.Internal.Stack.Decode
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -6545,6 +6545,15 @@ module GHC.Stack.Annotation.Experimental where
annotateStackString :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> b -> b
annotateStackStringIO :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b
+module GHC.Stack.Decode.Experimental where
+ -- Safety: None
+ type StackEntry :: *
+ data StackEntry = StackEntry {functionName :: GHC.Internal.Base.String, moduleName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Base.String, closureType :: GHC.Internal.ClosureTypes.ClosureType}
+ decodeStackWithFrameUnpack :: forall a. (GHC.Internal.Stack.Decode.StackFrameLocation -> GHC.Internal.Types.IO a) -> GHC.Internal.Stack.CloneStack.StackSnapshot -> GHC.Internal.Types.IO (GHC.Internal.Heap.InfoTable.Types.StgInfoTable, [a])
+ decodeStackWithIpe :: GHC.Internal.Stack.CloneStack.StackSnapshot -> GHC.Internal.Types.IO [(GHC.Internal.Heap.Closures.StackFrame, GHC.Internal.Maybe.Maybe GHC.Internal.InfoProv.Types.InfoProv)]
+ prettyStackEntry :: StackEntry -> GHC.Internal.Base.String
+ prettyStackFrameWithIpe :: (GHC.Internal.Heap.Closures.StackFrame, GHC.Internal.Maybe.Maybe GHC.Internal.InfoProv.Types.InfoProv) -> GHC.Internal.Maybe.Maybe GHC.Internal.Base.String
+
module GHC.Stats.Experimental where
-- Safety: Safe
type GCDetails :: *
@@ -11184,6 +11193,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Base.Void -- Defined in ‘GHC.Int
instance GHC.Internal.Classes.Eq GHC.Internal.IO.MaskingState -- Defined in ‘GHC.Internal.IO’
instance GHC.Internal.Classes.Eq GHC.Internal.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.Internal.RTS.Flags’
instance GHC.Internal.Classes.Eq GHC.Internal.IO.SubSystem.IoSubSystem -- Defined in ‘GHC.Internal.IO.SubSystem’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Classes’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Classes’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Classes’
@@ -11281,6 +11291,8 @@ instance GHC.Internal.Show.Show GHC.Internal.RTS.Flags.TickyFlags -- Defined in
instance GHC.Internal.Show.Show GHC.Internal.RTS.Flags.TraceFlags -- Defined in ‘GHC.Internal.RTS.Flags’
instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined in ‘GHC.Internal.IO.SubSystem’
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
+instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -6548,6 +6548,15 @@ module GHC.Stack.Annotation.Experimental where
annotateStackString :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> b -> b
annotateStackStringIO :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b
+module GHC.Stack.Decode.Experimental where
+ -- Safety: None
+ type StackEntry :: *
+ data StackEntry = StackEntry {functionName :: GHC.Internal.Base.String, moduleName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Base.String, closureType :: GHC.Internal.ClosureTypes.ClosureType}
+ decodeStackWithFrameUnpack :: forall a. (GHC.Internal.Stack.Decode.StackFrameLocation -> GHC.Internal.Types.IO a) -> GHC.Internal.Stack.CloneStack.StackSnapshot -> GHC.Internal.Types.IO (GHC.Internal.Heap.InfoTable.Types.StgInfoTable, [a])
+ decodeStackWithIpe :: GHC.Internal.Stack.CloneStack.StackSnapshot -> GHC.Internal.Types.IO [(GHC.Internal.Heap.Closures.StackFrame, GHC.Internal.Maybe.Maybe GHC.Internal.InfoProv.Types.InfoProv)]
+ prettyStackEntry :: StackEntry -> GHC.Internal.Base.String
+ prettyStackFrameWithIpe :: (GHC.Internal.Heap.Closures.StackFrame, GHC.Internal.Maybe.Maybe GHC.Internal.InfoProv.Types.InfoProv) -> GHC.Internal.Maybe.Maybe GHC.Internal.Base.String
+
module GHC.Stats.Experimental where
-- Safety: Safe
type GCDetails :: *
@@ -11187,6 +11196,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Base.Void -- Defined in ‘GHC.Int
instance GHC.Internal.Classes.Eq GHC.Internal.IO.MaskingState -- Defined in ‘GHC.Internal.IO’
instance GHC.Internal.Classes.Eq GHC.Internal.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.Internal.RTS.Flags’
instance GHC.Internal.Classes.Eq GHC.Internal.IO.SubSystem.IoSubSystem -- Defined in ‘GHC.Internal.IO.SubSystem’
+instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Classes’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Classes’
instance GHC.Internal.Classes.Ord GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Classes’
@@ -11284,6 +11294,8 @@ instance GHC.Internal.Show.Show GHC.Internal.RTS.Flags.TickyFlags -- Defined in
instance GHC.Internal.Show.Show GHC.Internal.RTS.Flags.TraceFlags -- Defined in ‘GHC.Internal.RTS.Flags’
instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined in ‘GHC.Internal.IO.SubSystem’
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
+instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56e45f1b464cf90010fa1cd142f45df…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56e45f1b464cf90010fa1cd142f45df…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] Fix LinkableUsage02 test
by Matthew Pickering (＠mpickering) 19 Mar '26
by Matthew Pickering (＠mpickering) 19 Mar '26
19 Mar '26
Matthew Pickering pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
6656b289 by Matthew Pickering at 2026-03-19T11:40:56+00:00
Fix LinkableUsage02 test
- - - - -
2 changed files:
- testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr
- testsuite/tests/bytecode/TLinkable/all.T
Changes:
=====================================
testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr
=====================================
@@ -1,21 +1,21 @@
-[ 1 of 21] Compiling Module001 ( Module001.hs, Module001.o, Module001.gbc )
-[ 2 of 21] Compiling Module002 ( Module002.hs, Module002.o, Module002.gbc )
-[ 3 of 21] Compiling Module003 ( Module003.hs, Module003.o, Module003.gbc )
-[ 4 of 21] Compiling Module004 ( Module004.hs, Module004.o, Module004.gbc )
-[ 5 of 21] Compiling Module005 ( Module005.hs, Module005.o, Module005.gbc )
-[ 6 of 21] Compiling Module006 ( Module006.hs, Module006.o, Module006.gbc )
-[ 7 of 21] Compiling Module007 ( Module007.hs, Module007.o, Module007.gbc )
-[ 8 of 21] Compiling Module008 ( Module008.hs, Module008.o, Module008.gbc )
-[ 9 of 21] Compiling Module009 ( Module009.hs, Module009.o, Module009.gbc )
-[10 of 21] Compiling Module010 ( Module010.hs, Module010.o, Module010.gbc )
-[11 of 21] Compiling Module011 ( Module011.hs, Module011.o, Module011.gbc )
-[12 of 21] Compiling Module012 ( Module012.hs, Module012.o, Module012.gbc )
-[13 of 21] Compiling Module013 ( Module013.hs, Module013.o, Module013.gbc )
-[14 of 21] Compiling Module014 ( Module014.hs, Module014.o, Module014.gbc )
-[15 of 21] Compiling Module015 ( Module015.hs, Module015.o, Module015.gbc )
-[16 of 21] Compiling Module016 ( Module016.hs, Module016.o, Module016.gbc )
-[17 of 21] Compiling Module017 ( Module017.hs, Module017.o, Module017.gbc )
-[18 of 21] Compiling Module018 ( Module018.hs, Module018.o, Module018.gbc )
-[19 of 21] Compiling Module019 ( Module019.hs, Module019.o, Module019.gbc )
-[20 of 21] Compiling Module020 ( Module020.hs, Module020.o, Module020.gbc )
-[21 of 21] Compiling LinkableUsage02 ( LinkableUsage02.hs, LinkableUsage02.o )
+[ 1 of 21] Compiling Module001 ( Module001.hs, Module001.gbc )
+[ 2 of 21] Compiling Module002 ( Module002.hs, Module002.gbc )
+[ 3 of 21] Compiling Module003 ( Module003.hs, Module003.gbc )
+[ 4 of 21] Compiling Module004 ( Module004.hs, Module004.gbc )
+[ 5 of 21] Compiling Module005 ( Module005.hs, Module005.gbc )
+[ 6 of 21] Compiling Module006 ( Module006.hs, Module006.gbc )
+[ 7 of 21] Compiling Module007 ( Module007.hs, Module007.gbc )
+[ 8 of 21] Compiling Module008 ( Module008.hs, Module008.gbc )
+[ 9 of 21] Compiling Module009 ( Module009.hs, Module009.gbc )
+[10 of 21] Compiling Module010 ( Module010.hs, Module010.gbc )
+[11 of 21] Compiling Module011 ( Module011.hs, Module011.gbc )
+[12 of 21] Compiling Module012 ( Module012.hs, Module012.gbc )
+[13 of 21] Compiling Module013 ( Module013.hs, Module013.gbc )
+[14 of 21] Compiling Module014 ( Module014.hs, Module014.gbc )
+[15 of 21] Compiling Module015 ( Module015.hs, Module015.gbc )
+[16 of 21] Compiling Module016 ( Module016.hs, Module016.gbc )
+[17 of 21] Compiling Module017 ( Module017.hs, Module017.gbc )
+[18 of 21] Compiling Module018 ( Module018.hs, Module018.gbc )
+[19 of 21] Compiling Module019 ( Module019.hs, Module019.gbc )
+[20 of 21] Compiling Module020 ( Module020.hs, Module020.gbc )
+[21 of 21] Compiling LinkableUsage02 ( LinkableUsage02.hs, LinkableUsage02.gbc )
=====================================
testsuite/tests/bytecode/TLinkable/all.T
=====================================
@@ -21,7 +21,7 @@ test('LinkableUsage02'
, req_th
]
, multimod_compile
- , ['LinkableUsage02', '-fwrite-byte-code -fprefer-byte-code'])
+ , ['LinkableUsage02', '-no-link -fbyte-code -fwrite-byte-code -fprefer-byte-code'])
test('linkable-space'
, [ extra_files(['genLinkables.sh', 'BCOTemplate.hs'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6656b28940377c83fbb0f5e292eb9dd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6656b28940377c83fbb0f5e292eb9dd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base] Onward [skip ci]
by Simon Peyton Jones (＠simonpj) 19 Mar '26
by Simon Peyton Jones (＠simonpj) 19 Mar '26
19 Mar '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC
Commits:
e65c697c by Simon Peyton Jones at 2026-03-19T00:05:50+00:00
Onward [skip ci]
- - - - -
9 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name.hs
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -129,7 +129,9 @@ import GHC.Unit.Types
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.Unique
+import GHC.Types.Unique.FM
import GHC.Builtin.Uniques
+import GHC.Builtin.Names.TH( thKnownKeyTable )
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Data.FastString
@@ -156,7 +158,7 @@ allNameStringList = Inf.toList allNameStrings
{-
************************************************************************
-* *
+o* *
\subsection{Local Names}
* *
************************************************************************
@@ -187,6 +189,14 @@ names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in GHC.Builtin.Types etc.
-}
+-- | `knownKeyOccMap` maps the OccName of a known-key to its Unique
+knownKeyOccMap :: OccEnv KnownKeyNameKey
+knownKeyOccMap = mkOccEnv (basicKnownKeyTable ++ thKnownKeyTable)
+
+knownKeyUniqMap :: UniqFM KnownKeyNameKey OccName
+knownKeyUniqMap = listToUFM [ (uniq, occ)
+ | (occ, uniq) <- basicKnownKeyTable ++ thKnownKeyTable ]
+
basicKnownKeyTable :: [(OccName, KnownKeyNameKey)]
basicKnownKeyTable
= [ (mkTcOcc "Rational", rationalTyConKey)
@@ -1604,11 +1614,6 @@ tcQual modu str unique = mk_known_key_name tcName modu str unique
clsQual modu str unique = mk_known_key_name clsName modu str unique
dcQual modu str unique = mk_known_key_name dataName modu str unique
-mk_known_key_name :: NameSpace -> Module -> FastString -> KnownKeyNameKey -> Name
-{-# INLINE mk_known_key_name #-}
-mk_known_key_name space modu str unique
- = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan
-
{-
************************************************************************
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -8,9 +8,8 @@ module GHC.Builtin.Names.TH where
import GHC.Prelude ()
-import GHC.Builtin.Names( mk_known_key_name )
import GHC.Unit.Types
-import GHC.Types.Name( Name )
+import GHC.Types.Name( Name, mk_known_key_name )
import GHC.Types.Name.Occurrence( OccName, tcName, clsName, dataName, varName, fieldName )
import GHC.Types.Name.Reader( RdrName, nameRdrName )
import GHC.Types.Unique ( Unique )
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -19,16 +19,15 @@
--
module GHC.Builtin.Utils (
-- * Known-key names
- isKnownKeyName,
- lookupKnownKeyName,
- lookupKnownNameInfo,
+ oldIsKnownKeyName,
+ oldLookupKnownKeyName,
+ oldLookupKnownNameInfo,
-- ** Internal use
-- | 'knownKeyNames' is exported to seed the original name cache only;
-- if you find yourself wanting to look at it you might consider using
-- 'lookupKnownKeyName' or 'isKnownKeyName'.
knownKeyNames,
- knownKeyOccMap, knownKeyUniqMap,
-- * Miscellaneous
wiredInIds, ghcPrimIds,
@@ -54,7 +53,7 @@ import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names.TH ( templateHaskellNames, thKnownKeyTable )
+import GHC.Builtin.Names.TH ( templateHaskellNames )
import GHC.Builtin.Names
import GHC.Core.ConLike ( ConLike(..) )
@@ -193,38 +192,34 @@ knownKeyNamesOkay all_names
text ": " <>
brackets (pprWithCommas (ppr . nameOccName) ns)
+--------------- ToDo: get rid of these old-mechanism functions
+--------------- when we complete the known-key tranitition
+-------------- See #27013
+
-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
-- known-key thing.
-lookupKnownKeyName :: Unique -> Maybe Name
-lookupKnownKeyName u =
- knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
+oldLookupKnownKeyName :: Unique -> Maybe Name
+oldLookupKnownKeyName u =
+ knownUniqueName u <|> lookupUFM_Directly oldKnownKeysMap u
-- TODO: remove this once all knownkey names come from providers
-- | Is a 'Name' known-key?
-isKnownKeyName :: Name -> Bool
-isKnownKeyName n =
- isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
-
--- | `knownKeyOccMap` maps the OccName of a known-key to its Unique
-knownKeyOccMap :: OccEnv Unique
-knownKeyOccMap = mkOccEnv (basicKnownKeyTable ++ thKnownKeyTable)
-
-knownKeyUniqMap :: UniqFM Unique OccName
-knownKeyUniqMap = listToUFM [ (uniq, occ)
- | (occ, uniq) <- basicKnownKeyTable ++ thKnownKeyTable ]
+oldIsKnownKeyName :: Name -> Bool
+oldIsKnownKeyName n =
+ isJust (knownUniqueName $ nameUnique n) || elemUFM n oldKnownKeysMap
-- | Maps 'Unique's to known-key names.
--
-- The type is @UniqFM Name Name@ to denote that the 'Unique's used
-- in the domain are 'Unique's associated with 'Name's (as opposed
-- to some other namespace of 'Unique's).
-knownKeysMap :: UniqFM Name Name
-knownKeysMap = listToIdentityUFM knownKeyNames
+oldKnownKeysMap :: UniqFM Name Name
+oldKnownKeysMap = listToIdentityUFM knownKeyNames
-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command.
-lookupKnownNameInfo :: Name -> SDoc
-lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
+oldLookupKnownNameInfo :: Name -> SDoc
+oldLookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
-- If we do find a doc, we add comment delimiters to make the output
-- of ':info' valid Haskell.
Nothing -> empty
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -32,8 +32,8 @@ module GHC.Iface.Binary (
import GHC.Prelude
-import GHC.Builtin.Utils ( knownKeyOccMap, isKnownKeyName, lookupKnownKeyName )
-
+import GHC.Builtin.Utils ( oldIsKnownKeyName, oldLookupKnownKeyName )
+import GHC.Builtin.Names ( knownKeyOccMap )
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Utils.Outputable
@@ -725,7 +725,7 @@ putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
- | isKnownKeyName name
+ | oldIsKnownKeyName name
, let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
= -- assert (u < 2^(22 :: Int))
put_ bh (0x80000000
@@ -758,7 +758,7 @@ getSymtabName symtab bh = do
ix = fromIntegral i .&. 0x003FFFFF
u = mkUniqueGrimilyWithTag tag ix
in
- return $! case lookupKnownKeyName u of
+ return $! case oldLookupKnownKeyName u of
Nothing -> pprPanic "getSymtabName:unknown known-key unique"
(ppr i $$ ppr u $$ char tag $$ ppr ix)
Just n -> n
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -16,7 +16,8 @@ module GHC.Iface.Load (
-- Importing one thing
importDecl,
checkWiredInTyCon, ifCheckWiredInThing,
- lookupKnownKeyThing, loadGlobalName,
+ lookupKnownKeyThing, lookupKnownKeyName,
+ loadGlobalName,
-- RnM/TcM functions
loadModuleInterface, loadModuleInterfaces,
@@ -63,6 +64,9 @@ import GHC.Iface.Rename
import GHC.Iface.Env
import GHC.Iface.Errors as Iface_Errors
+import GHC.Rename.Env( addUsedGRE )
+import GHC.Rename.Utils( DeprecationWarnings(..) )
+
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
@@ -134,9 +138,16 @@ import qualified GHC.Unit.Home.Graph as HUG
********************************************************************* -}
lookupKnownKeyThing :: HasDebugCallStack
- => Maybe GlobalRdrEnv -> Unique
+ => Maybe GlobalRdrEnv -> KnownKeyNameKey
-> IfM lcl (MaybeErr IfaceMessage TyThing)
-lookupKnownKeyThing Nothing uniq
+lookupKnownKeyThing mb_gbl_rdr_env key
+ = do { name <- lookupKnownKeyName mb_gbl_rdr_env key
+ ; lookupGlobalName name }
+
+lookupKnownKeyName :: HasDebugCallStack
+ => Maybe GlobalRdrEnv -> KnownKeyNameKey
+ -> IfM lcl Name
+lookupKnownKeyName Nothing uniq
= do { known_key_name_map <- loadKnownKeyOccMap
; let name = lookupUFM known_key_name_map uniq
`orElse` pprPanic "lookupKnownKeyThing 1"
@@ -144,17 +155,23 @@ lookupKnownKeyThing Nothing uniq
, text "occ-map" <+> ppr known_key_name_map ])
; traceIf $ hang (text "lookupKnownKeyThing ImplicitKnownKeyNames")
2 (ppr name <+> ppr uniq)
- ; lookupGlobalName name }
+ ; return name }
-lookupKnownKeyThing (Just gbl_rdr_env) uniq
- -- Look up the known-key OccName in the current top-level GlobalRdrEnv
+lookupKnownKeyName (Just gbl_rdr_env) uniq
+ -- Just gbl_rdr_env: we have -frebindable-known-key-names on, and
+ -- here is the top-level GlobalRdrEnv
+ -- Look up the known-key OccName in the GlobalRdrEnv
-- If we get a unique hit, use it; if not, panic.
= case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of
[gre] -> do { let name = greName gre
+ ; addUsedGRE NoDeprecationWarnings gre
+ -- addUseGRE: don't complain about unused imports
+ -- of known-key names when -frebindable-known-key-names
; traceIf $ hang (text "lookupKnownKeyThing NoImplicitKnownKeyNames")
2 (ppr name <+> ppr uniq)
- ; lookupGlobalName name }
- gres -> pprPanic "lookupKnownKeyOcc" (ppr occ $$ ppr gres)
+ ; return name }
+ [] -> pprPanic "lookupKnownKeyOcc: known-key name is not in scope" (ppr occ)
+ gres -> pprPanic "lookupKnownKeyOcc: known-key name is ambiguously in scope" (ppr gres)
where
occ = lookupUFM knownKeyUniqMap uniq
`orElse` pprPanic "lookupKnownKeyThing 2"
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2960,7 +2960,7 @@ tcRnGetInfo hsc_env name
; thing <- tcRnLookupName' name
; fixity <- lookupFixityRn name
; (cls_insts, fam_insts) <- lookupInsts thing
- ; let info = lookupKnownNameInfo name
+ ; let info = oldLookupKnownNameInfo name
; return (thing, fixity, cls_insts, fam_insts, info) }
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -50,6 +50,8 @@ module GHC.Types.Name (
mkFCallName,
mkExternalName, mkWiredInName, mkKnownKeyName,
+ mk_known_key_name, -- Temporary. ToDo: get rid of me #27013
+
-- ** Manipulating and deconstructing 'Name's
nameUnique, setNameUnique,
nameOccName, nameNameSpace, nameModule, nameModule_maybe, extNamePieces,
@@ -161,15 +163,28 @@ To implement all this, here are the moving parts:
eqClassKey = mkPreludeClassUnique 3
* All the known-key names are gathered in one table:
- basicKnownKeyTable :: [(OccName, KnownKeyNameKey)]
- basicKnownKeyTable
- = [ (mkTcOcc "Rational", rationalTyConKey)
- , (mkTcOcc "Eq", eqClassKey)
- ... etc ...
+ basicKnownKeyTable :: [(OccName, KnownKeyNameKey)]
+ basicKnownKeyTable
+ = [ (mkTcOcc "Rational", rationalTyConKey)
+ , (mkTcOcc "Eq", eqClassKey)
+ ... etc ...
+
+ INVARIANT (KnownKeyInvariant): It is a requirement that all known-key names
+ have distinct OccNames. (We could have multiple name-spaces, but in practice
+ this is not an onerous restriction.)
+
+* Because of (KnownKeyInvariant) we can turn that table into two mappings:
+
+ knownKeyOccMap :: OccEnv KnownKeyNameKey
+ knownKeyOccMap = mkOccEnv (basicKnownKeyTable ++ thKnownKeyTable)
-* INVARIANT: It is a requirement that all known-key names have distinct
- OccNames. (We could have multiple name-spaces, but in practice this is not an
- onerous restriction.)
+ knownKeyUniqMap :: UniqFM KnownKeyNameKey OccName
+
+* There are two flags that control the treatment of known-key names:
+ -frebindable-known-key-names
+ -fdefines-known-key-names
+
+* When processing source code, /without/ -frebindable
Note [About the NameSorts]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -360,6 +375,14 @@ hasKnownKey :: Uniquable a => a -> KnownKeyNameKey -> Bool
-- See if a thing has a particular known key
hasKnownKey = hasKey
+-- ToDo: get rid of this function when we complete the known-key name transition
+-- see #27013
+mk_known_key_name :: NameSpace -> Module -> FastString -> KnownKeyNameKey -> Name
+{-# INLINE mk_known_key_name #-}
+mk_known_key_name space modu str unique
+ = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan
+
+
{- *********************************************************************
* *
=====================================
libraries/ghc-internal/src/GHC/Internal/Base.hs
=====================================
@@ -82,6 +82,9 @@ Other Prelude modules are much easier with fewer complex dependencies.
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE Unsafe #-}
+{-# OPTIONS_GHC -fdefines-known-key-names #-}
+ -- Defines Monad
+
-- -Wno-orphans is needed for things like:
-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0
{-# OPTIONS_GHC -Wno-orphans #-}
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -31,7 +31,9 @@ module GHC.Internal.TH.Lift
import GHC.Internal.TH.Syntax
import GHC.Internal.TH.Monad
-import qualified GHC.Internal.TH.Lib as Lib (litE) -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
+import qualified GHC.Internal.TH.Lib as Lib (litE)
+ -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
+import GHC.Internal.Base( Monad ) -- Needed for known-key lookup
import GHC.Internal.Data.Either
import GHC.Internal.Base (String, Void, map, mapM, ord, return, (.))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e65c697c3dc0d98e5a4df391e55dda3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e65c697c3dc0d98e5a4df391e55dda3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ani/tc-expand] making HsExpansion a new datatype
by Apoorv Ingle (＠ani) 18 Mar '26
by Apoorv Ingle (＠ani) 18 Mar '26
18 Mar '26
Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC
Commits:
25625e1e by Apoorv Ingle at 2026-03-18T18:17:17-05:00
making HsExpansion a new datatype
- - - - -
17 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -660,10 +660,14 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
+-- See Note [Rebindable syntax and XXExprGhcRn]
+-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+data HsExpansion p = HSE { hs_ctxt :: HsCtxt -- The original source thing context to be used for error messages
+ , expanded_expr :: LHsExpr p } -- The compiler generated, expanded expression
+ -- This is located because of do statements (TODO ANI : Add Note)
+
data XXExprGhcRn
- = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages
- , xrn_expanded :: LHsExpr GhcRn } -- The compiler generated, expanded thing
- -- This is located because of do statements (TODO ANI : Add Note)
+ = ExpandedThingRn (HsExpansion GhcRn) -- ^ Renamed/Pre Typecheck expanded expression
| HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector
-- See Note [Non-overloaded record field selectors] and
@@ -673,11 +677,7 @@ data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
- | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
- -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- { xtc_orig :: HsCtxt -- The original user written thing
- , xtc_expanded :: LHsExpr GhcTc } -- The expanded typechecked expression
- -- This is located because of do statements (TODO ANI: Add NOTE)
+ | ExpandedThingTc (HsExpansion GhcTc) -- ^ Typechecked expanded expression
| ConLikeTc
-- ^ A 'ConLike', either a data constructor or pattern synonym
@@ -1019,9 +1019,15 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
-instance Outputable XXExprGhcRn where
- ppr (HsRecSelRn f) = pprPrefixOcc f
- ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
+
+ppr_hse :: forall p. (IsPass p) => HsExpansion (GhcPass p) -> SDoc
+ppr_hse hse
+ = case ghcPass @p of
+ GhcPs -> empty
+ GhcRn -> case hse of
+ HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
+ GhcTc -> case hse of
+ HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o)
where
ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x
pprCtxt :: HsCtxt -> SDoc
@@ -1031,26 +1037,17 @@ instance Outputable XXExprGhcRn where
pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e)
pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty
+instance Outputable XXExprGhcRn where
+ ppr (HsRecSelRn f) = pprPrefixOcc f
+ ppr (ExpandedThingRn hse) = ppr_hse hse
+
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr co_fn e)
= pprHsWrapper co_fn (\_parens -> pprExpr e)
- ppr (ExpandedThingTc o e)
- = ifPprDebug (braces $ vcat [pprCtxt o, ppr e]) (pprCtxt o)
-
- where
- ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x
- pprCtxt :: HsCtxt -> SDoc
- pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e)
- pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt)
- pprCtxt (StmtErrCtxtPat pat) = ppr_builder "<OrigPat>:" (ppr pat)
- pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e)
- pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty
-
- -- e is the expanded expression, we print the original
- -- expression (HsExpr GhcRn), not the
- -- expanded typechecked one (HsExpr GhcTc),
- -- unless we are in ppr's debug mode printed both
+ ppr (ExpandedThingTc hse)
+ = ppr_hse hse
ppr (ConLikeTc con) = pprPrefixOcc con
-- Used in error messages generated by
@@ -1083,12 +1080,12 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn (HSE thing _)) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e
-ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_tc (ExpandedThingTc (HSE thing _)) = ppr_infix_hs_expansion thing
ppr_infix_expr_tc (ConLikeTc con) = Just (pprInfixOcc (conLikeName con))
ppr_infix_expr_tc (HsTick {}) = Nothing
ppr_infix_expr_tc (HsBinTick {}) = Nothing
@@ -1176,14 +1173,14 @@ hsExprNeedsParens prec = go
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e
- go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing
+ go_x_tc (ExpandedThingTc (HSE thing _)) = hsExpandedNeedsParens thing
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsRecSelTc{}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing
+ go_x_rn (ExpandedThingRn (HSE thing _)) = hsExpandedNeedsParens thing
go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: HsCtxt -> Bool
@@ -1228,14 +1225,14 @@ isAtomicHsExpr (XExpr x)
where
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr _ e) = isAtomicHsExpr e
- go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
+ go_x_tc (ExpandedThingTc (HSE thing _)) = isAtomicExpandedThingRn thing
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
go_x_tc (HsRecSelTc{}) = True
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (ExpandedThingRn (HSE thing _)) = isAtomicExpandedThingRn thing
go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: HsCtxt -> Bool
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -647,6 +647,9 @@ instance Data HsCtxt where
deriving instance Data XXExprGhcRn
+deriving instance Data (HsExpansion GhcRn)
+deriving instance Data (HsExpansion GhcTc)
+
deriving instance Data a => Data (WithUserRdr a)
-- -------------------------------
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -153,7 +153,7 @@ hsExprType (HsQual x _ _) = dataConCantHappen x
hsExprType (HsForAll x _ _) = dataConCantHappen x
hsExprType (HsFunArr x _ _ _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpandedThingTc _ e)) = lhsExprType e
+hsExprType (XExpr (ExpandedThingTc (HSE _ e))) = lhsExprType e
hsExprType (XExpr (ConLikeTc con)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -307,7 +307,7 @@ dsExpr e@(XExpr ext_expr_tc)
WrapExpr {} -> dsApp e
ConLikeTc {} -> dsApp e
- ExpandedThingTc _ e -> dsLExpr e
+ ExpandedThingTc (HSE _ e) -> dsLExpr e
-- Hpc Support
HsTick tickish e -> do
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -1166,7 +1166,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- we have to compare the wrappers
exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =
wrap h h' && exp e e'
- exp (XExpr (ExpandedThingTc _ x)) (XExpr (ExpandedThingTc _ x'))
+ exp (XExpr (ExpandedThingTc (HSE _ x))) (XExpr (ExpandedThingTc (HSE _ x')))
= lexp x x'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (HsIPVar _ i) (HsIPVar _ i') =
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1735,7 +1735,7 @@ repE (HsFunArr _ mult arg res) = do
arg' <- repLE arg
res' <- repLE res
repApps fun [arg', res']
-repE e@(XExpr (ExpandedThingRn o x))
+repE e@(XExpr (ExpandedThingRn (HSE o x)))
| ExprCtxt e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -415,7 +415,7 @@ addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
- TickForCoverage | XExpr (ExpandedThingTc StmtErrCtxt{} _) <- e0 -- expansion ticks are handled separately
+ TickForCoverage | XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _)) <- e0 -- expansion ticks are handled separately
-> dont_tick_it
| otherwise -> tick_it
TickCallSites | isCallSite e0 -> tick_it
@@ -484,14 +484,14 @@ addTickLHsExprNever (L pos e0) = do
-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (XExpr (ExpandedThingTc (StmtErrCtxt{}) _)) = False
+isGoodBreakExpr (XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _))) = False
isGoodBreakExpr e = isCallSite e
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppType{} = True
isCallSite HsCase{} = True
-isCallSite (XExpr (ExpandedThingTc _ e))
+isCallSite (XExpr (ExpandedThingTc (HSE _ e)))
= isCallSite (unLoc e)
-- NB: OpApp, SectionL, SectionR are all expanded out
@@ -637,7 +637,7 @@ addTickHsExpr (HsProc x pat cmdtop) =
addTickHsExpr (XExpr (WrapExpr w e)) =
liftM (XExpr . WrapExpr w) $
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
+addTickHsExpr (XExpr (ExpandedThingTc hse)) = addTickHsExpanded hse
addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-- We used to do a freeVar on a pat-syn builder, but actually
@@ -660,8 +660,8 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
-addTickHsExpanded :: HsCtxt -> LHsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
+addTickHsExpanded :: HsExpansion GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpanded (HSE o e) = liftM (XExpr . ExpandedThingTc . HSE o) $ case o of
-- We always want statements to get a tick, so we can step over each one.
-- To avoid duplicates we blacklist SrcSpans we already inserted here.
StmtErrCtxt _ (L pos _) -> do_tick_black pos
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -755,7 +755,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
- XExpr (ExpandedThingTc thing e)
+ XExpr (ExpandedThingTc (HSE thing e))
| ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax
-> Just (lhsExprType e)
| otherwise -> computeLType e
@@ -1352,7 +1352,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
WrapExpr w a
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
- ExpandedThingTc _ e
+ ExpandedThingTc (HSE _ e)
-> [ toHie e ]
ConLikeTc con
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -847,8 +847,9 @@ mkExpandedStmt oStmt flav eExpr = mkExpandedRn (StmtErrCtxt (HsDoStmt flav) oStm
mkExpandedRn
:: HsCtxt -- ^ source, user written do statement/expression
-> LHsExpr GhcRn -- ^ expanded typechecked expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedRn orig expr = XExpr (ExpandedThingRn orig expr)
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedRn o e = XExpr (ExpandedThingRn (HSE o e))
+
-- | Build a 'XXExprGhcRn' out of an extension constructor,
-- and the two components of the expansion: original and
@@ -862,5 +863,5 @@ mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) (wrapGenSpan eExpr)
mkExpandedTc
:: HsCtxt -- ^ source, user written do statement/expression
-> LHsExpr GhcTc -- ^ expanded typechecked expression
- -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedTc o e = XExpr (ExpandedThingTc o e)
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc'
+mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e))
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1246,7 +1246,7 @@ expr_to_type earg =
| otherwise = not_in_scope
where occ = occName rdr
not_in_scope = failWith $ TcRnNotInScope NotInScope rdr
- go (L l (XExpr (ExpandedThingRn (ExprCtxt orig) _))) =
+ go (L l (XExpr (ExpandedThingRn (HSE (ExprCtxt orig) _)))) =
-- Use the original, user-written expression (before expansion).
-- Example. Say we have vfun :: forall a -> blah
-- and the call vfun (Maybe [1,2,3])
@@ -1937,7 +1937,7 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn
-> Scaled TcRhoType -- Deeply skolemised
-> TcM (HsExprArg 'TcpInst)
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
-quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Scaled _ orig_arg_rho)
+quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
= addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints
-- generated by calls in arg
do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg
@@ -1968,7 +1968,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
<- captureConstraints $
tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
-- We must capture type-class and equality constraints here, but
- -- not equality constraints. See (QLA6) in Note [Quick Look at
+ -- not usage information. See (QLA6) in Note [Quick Look at
-- value arguments]
; traceTc "quickLookArg 2" $
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -45,8 +45,8 @@ import Data.List ((\\))
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
-expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts
+expandDoStmts :: HsDoFlavour -> XRec GhcRn [ExprLStmt GhcRn] -> TcM (HsExpansion GhcRn)
+expandDoStmts doFlav lstmts@(L _ stmts) = HSE (ExprCtxt (HsDo noExtField doFlav lstmts)) <$> expand_do_stmts doFlav stmts
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
@@ -234,7 +234,7 @@ See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion
(`HsExpr GhcRn -> HsExpr GhcRn`)
-This expansion is done right before typechecking and after renaming
+This expansion is done after renaming and before typechecking
See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr`
Historical note START
@@ -423,10 +423,10 @@ It stores the original statement (with location) and the expanded expression
‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression
-- Expanded Do Expression
(‹ExpandedThingRn e1› -- Original Statement
- ({(>>) ‹ExpandedThingRn e1› e1} -- Expanded Expression
+ ({(>>) e1} -- Expanded Expression
(‹ExpandedThingRn e2›
- ({(>>) ‹ExpandedThingRn e2› e2}
- (‹ExpandedThingRn e3› {e3})))))
+ ({(>>) e2}
+ (‹ExpandedThingRn e3› {e3})))))
* Whenever the typechecker steps through an `ExpandedThingRn`,
we push the original statement in the error context, set the error location to the
@@ -481,6 +481,4 @@ It stores the original statement (with location) and the expanded expression
mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
-mkExpandedPatRn pat e = XExpr $ ExpandedThingRn
- { xrn_orig = StmtErrCtxtPat pat
- , xrn_expanded = wrapGenSpan e}
+mkExpandedPatRn pat e = mkExpandedRn (StmtErrCtxtPat pat) (wrapGenSpan e)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -316,7 +316,8 @@ tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
-tcExpr (XExpr e') res_ty = tcXExpr e' res_ty
+tcExpr (XExpr (ExpandedThingRn hse)) res_ty = tcHsExpansion hse res_ty
+tcExpr e@(XExpr{}) res_ty = tcApp e res_ty
-- Typecheck an occurrence of an unbound Id
--
@@ -557,7 +558,7 @@ tcExpr (HsMultiIf _ alts) res_ty
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
-tcExpr expr@(HsDo _ do_or_lc stmts) res_ty
+tcExpr (HsDo _ do_or_lc stmts) res_ty
| DoExpr{} <- do_or_lc
-- ApplicativeDo are typechecked using tcDoStmts
= do isApplicativeDo <- xoptM LangExt.ApplicativeDo
@@ -565,12 +566,13 @@ tcExpr expr@(HsDo _ do_or_lc stmts) res_ty
then tcDoStmts do_or_lc stmts res_ty
-- Expand expression on the fly otherwise
-- See Note [Typechecking by expansion: overview]
- else do { expr' <- tcExpandExpr expr
- ; tcExpr expr' res_ty }
+ else do { hse <- expandDoStmts do_or_lc stmts
+ ; tcHsExpansion hse res_ty }
| MDoExpr{} <- do_or_lc
- = do expr' <- tcExpandExpr expr
- tcExpr expr' res_ty
+ = do hse <- expandDoStmts do_or_lc stmts
+ tcHsExpansion hse res_ty
| otherwise
+ -- ListComp, MonadComp are handled by tcDoStmts
= tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc x pat cmd) res_ty
@@ -686,7 +688,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
; (ds_expr, ds_res_ty, err_msg)
<- expandRecordUpd record_expr possible_parents rbnds res_ty
- ; setInGeneratedCode $ addErrCtxt err_msg $
+ ; addErrCtxt err_msg $
do { -- Typecheck the expanded expression.
expr' <- tcExpr ds_expr (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
@@ -815,7 +817,7 @@ The rest of this Note explains how that is done.
hence `RealSrcSpan`.
The `tcl_err_ctxt` is a stack of contexts, each saying something
- like "In the expression: x+y" or "In the record update: r { x=2 }"
+ like "In the expression: x+y" or "In second argument of `$` namely 'r { x=2 }'"
The `tcl_in_gen_code` is a boolean that keeps track of whether
the current expression being typechecked is compiler generated
@@ -847,17 +849,13 @@ The rest of this Note explains how that is done.
-}
-tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcXExpr (ExpandedThingRn o e) res_ty
+tcHsExpansion :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcHsExpansion (HSE o e) res_ty
= mkExpandedTc o <$> -- necessary for hpc ticks
-- Need to call tcExpr and not tcApp
-- as e can be let statement which tcApp cannot gracefully handle
tcMonoLExpr e res_ty
--- For record selection, same as HsVar case
-tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
-
-
{-
************************************************************************
* *
@@ -1859,14 +1857,3 @@ checkMissingFields con_like rbinds arg_tys
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
-
-
--- Expands the expression on the fly
--- See Note [Handling overloaded and rebindable constructs]
--- See Note [Typechecking by expansion: overview]
-tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
-tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts))
- = do { expanded_expr <- expandDoStmts flav stmts
- ; return (mkExpandedLExpr orig_expr expanded_expr) }
-
-tcExpandExpr e = return e
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -462,7 +462,7 @@ tcInferAppHead_maybe fun = case fun of
ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty)
HsOverLit _ lit -> Just <$> with_get_ds (tcInferOverLit lit)
XExpr (HsRecSelRn f) -> Just <$> with_get_ds (tcInferRecSelId f)
- XExpr (ExpandedThingRn o (L loc e)) -> setSrcSpan (locA loc) $ Just <$> (
+ XExpr (ExpandedThingRn (HSE o (L loc e))) -> setSrcSpan (locA loc) $ Just <$> (
-- We do not want to instantiate the type of the head as there may be
-- visible type applications in the argument.
-- c.f. T19167
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -625,7 +625,7 @@ exprCtOrigin (HsIf {}) = IfThenElseOrigin
exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p)
exprCtOrigin (RecordUpd{}) = RecordUpdOrigin
exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f))
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = errCtxtCtOrigin o
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
srcCodeOriginCtOrigin :: HsCtxt -> CtOrigin
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1089,7 +1089,7 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan loc _) thing_inside
= updLclCtxt (\ctxt -> ctxt {tcl_loc = loc, tcl_in_gen_code = False}) thing_inside
setSrcSpan (GeneratedSrcSpan{}) thing_inside
- = setInGeneratedCode $ thing_inside
+ = updLclCtxt (\ctxt -> ctxt {tcl_in_gen_code = True}) thing_inside
setSrcSpan _ thing_inside
= thing_inside
@@ -1355,8 +1355,8 @@ addLExprCtxt lspan e thing_inside
-- error context. c.f. RecordDotSyntaxFail9
-- Add the original HsCtxt if we are typechecking an expanded expression
ExprWithTySig _ (L _ e') _
- | XExpr (ExpandedThingRn o _) <- e' -> addErrCtxt o thing_inside
- XExpr (ExpandedThingRn o _) -> addErrCtxt o thing_inside
+ | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside
+ XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside
_ -> addErrCtxt (ExprCtxt e) thing_inside
}
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -2047,7 +2047,7 @@ getDeepSubsumptionFlag_DataConHead app_head =
go app_head
| XExpr (ConLikeTc (RealDataCon {})) <- app_head
= Deep TopSub
- | XExpr (ExpandedThingTc _ (L _ f)) <- app_head
+ | XExpr (ExpandedThingTc (HSE _ (L _ f))) <- app_head
= go f
| XExpr (WrapExpr _ f) <- app_head
= go f
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1095,9 +1095,9 @@ zonkExpr (XExpr (WrapExpr co_fn expr))
do new_expr <- zonkExpr expr
return (XExpr (WrapExpr new_co_fn new_expr))
-zonkExpr (XExpr (ExpandedThingTc thing e))
+zonkExpr (XExpr (ExpandedThingTc (HSE thing e)))
= do e' <- zonkLExpr e
- return $ XExpr (ExpandedThingTc thing e')
+ return $ XExpr (ExpandedThingTc (HSE thing e'))
zonkExpr e@(XExpr (ConLikeTc {}))
= return e
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25625e1e23f81193423092ad1f6fbd4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25625e1e23f81193423092ad1f6fbd4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0