Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC
Commits:
7ef903c6 by Apoorv Ingle at 2026-03-16T16:03:06-05:00
accept test case
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
Changes:
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -113,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'
@@ -121,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)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1865,10 +1865,6 @@ checkMissingFields con_like rbinds arg_tys
tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts))
= do { expanded_expr <- expandDoStmts flav stmts
- -- 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 StmtErrCtxt
- -- in dsExpr of ExpandedThingTc
; return (mkExpandedLExpr orig_expr expanded_expr) }
tcExpandExpr e = 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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ef903c67692379bbf4cfb93e4f380d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ef903c67692379bbf4cfb93e4f380d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Magnus pushed new branch wip/mangoiv/26814 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mangoiv/26814
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ani/tc-expand] make HsExpandedRn and HsExpandedTc payload LExpr, add tcExpand for expanding...
by Apoorv Ingle (＠ani) 16 Mar '26
by Apoorv Ingle (＠ani) 16 Mar '26
16 Mar '26
Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC
Commits:
95b5f2cb by Apoorv Ingle at 2026-03-16T13:35:36-05:00
make HsExpandedRn and HsExpandedTc payload LExpr, add tcExpand for expanding Do expressions before typechecking in tcExpr
- - - - -
15 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/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
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/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
@@ -77,7 +76,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))]
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return $ L sloc (mkExpandedStmt stmt flav (unLoc body))
+ = return $ L sloc (mkExpandedStmt stmt flav (unLoc body)) -- TODO ANI: why not just body?
| SyntaxExprRn ret <- ret_expr -- We have unfortunately lost the location on the return function :(
--
@@ -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
+
{-
************************************************************************
* *
@@ -562,7 +565,17 @@ 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
+ = do isApplicativeDo <- xoptM LangExt.ApplicativeDo
+ if isApplicativeDo
+ then tcDoStmts do_or_lc stmts res_ty
+ 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
@@ -809,7 +822,7 @@ The rest of this Note explains how that is done.
like "In the expression: x+y" or "In the record update: r { x=2 }"
* 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,16 @@ checkMissingFields con_like rbinds arg_tys
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
+
+-- Expands the expression
+tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
+tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts))
+ = do { expanded_expr <- expandDoStmts flav stmts
+ -- 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 StmtErrCtxt
+ -- in dsExpr of ExpandedThingTc
+ ; 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,11 +462,11 @@ 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)) -> 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)) <$>
+ (\ (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
=====================================
@@ -1334,7 +1334,7 @@ addLExprCtxt lspan e thing_inside
| not (isGeneratedSrcSpan lspan)
= setSrcSpan lspan $ add_expr_ctxt e thing_inside
| otherwise -- no op in generated code
- = thing_inside
+ = setSrcSpan lspan $ thing_inside
where
add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
add_expr_ctxt e thing_inside
@@ -1349,10 +1349,10 @@ addLExprCtxt lspan e thing_inside
-- 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
+ | XExpr (ExpandedThingRn o _) <- e' -> addErrCtxt o thing_inside
-- Flip error ctxt into expansion mode
- XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
+ XExpr (ExpandedThingRn o _) -> addErrCtxt o thing_inside
_ -> addErrCtxt (ExprCtxt e) thing_inside
=====================================
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 {}))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/95b5f2cb50612f64e66c73e463a8714…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/95b5f2cb50612f64e66c73e463a8714…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
16 Mar '26
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
21f61eae by Simon Peyton Jones at 2026-03-16T17:44:46+00:00
Weird fix: check me
- - - - -
1 changed file:
- compiler/GHC/Core/Rules.hs
Changes:
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -731,8 +731,9 @@ matchRule _ ise is_active _ target_args rough_args
, not (ruleCantMatch tpl_tops rough_args)
, Just (bind_wrapper, matched_es) <- matchExprs ise tpl_vars tpl_args target_args
= Just (bind_wrapper $
- mkLets [NonRec b e | (b,e) <- zip tpl_vars matched_es] $
- rhs )
+-- mkLets [NonRec b e | (b,e) <- zip tpl_vars matched_es] $
+-- rhs
+ mkLams tpl_vars rhs `mkApps` matched_es )
| otherwise
= Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21f61eaedbc837d8b736ea6b49f50d2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21f61eaedbc837d8b736ea6b49f50d2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC
Commits:
7a5b42ad by sheaf at 2026-03-16T16:38:57+01:00
Simplify mkTick
This commit simplifies 'GHC.Core.Utils.mkTick', removing the
accumulating parameter 'rest' which was suspiciously treating a bunch of
different ticks as a group, and moving the group as a whole around the
AST, ignoring that the ticks in the group might have different placement
properties.
Also adds Note [Pushing SCCs inwards] which clarifies the logic for
pushing SCCs into lambdas, constructor applications, and dropping SCCs
around non-function variables (in particular the treatment of splittable
ticks).
A few other changes are also implemented:
- simplify 'can_split' predicate (no functional change)
- drop profiling ticks around coercions, fixing #26941
- combine profiling ticks into one when possible
Fixes #26878 and #26941
Co-authored-by: simonpj <simon.peytonjones(a)gmail.com>
- - - - -
5 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Types/Tickish.hs
- + testsuite/tests/simplCore/should_compile/T26941.hs
- + testsuite/tests/simplCore/should_compile/T26941_aux.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -303,101 +303,194 @@ mkCast expr co
* *
********************************************************************* -}
--- | Wraps the given expression in the source annotation, dropping the
--- annotation if possible.
+-- | Wraps the given expression in a Tick, floating the tick as far into
+-- the AST as possible in order to try to satisfy the tick's desired placement
+-- properties (as per Note [Tickish placement] in GHC.Types.Tickish).
+--
+-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor.
+--
+-- Also performs small on-the-fly optimisations:
+--
+-- * Eliminate unnecessary ticks by either absorbing them into existing ones
+-- or dropping them if that is valid (e.g. dropping profiling ticks around
+-- types, coercions and literals).
+-- * Split profiling ticks into counting/scoping parts so that the two parts
+-- can be placed independently into the AST.
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
-mkTick t orig_expr = mkTick' id orig_expr
+mkTick t orig_expr = mkTick' orig_expr
where
-- Some ticks (cost-centres) can be split in two, with the
-- non-counting part having laxer placement properties.
- canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
+ -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish.
+ can_split = tickishCanSplit t
- -- mkTick' handles floating of ticks *into* the expression.
- mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with)
- -- Always a composition of (Tick t) wrappers
- -> CoreExpr -- Current expression
- -> CoreExpr
- -- So in the call (mkTick' rest e), the expression
- -- (rest e)
- -- has the same type as e
- -- Returns an expression equivalent to (Tick t (rest e))
- mkTick' rest expr = case expr of
- -- Float ticks into unsafe coerce the same way we would do with a cast.
- Case scrut bndr ty alts@[Alt ac abs _rhs]
- | Just rhs <- isUnsafeEqualityCase scrut bndr alts
- -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)]
+ stop_here e = Tick t e -- Just wrap `t` around the current expression
+ -- That's the default option!
- -- Cost centre ticks should never be reordered relative to each
- -- other. Therefore we can stop whenever two collide.
+ -- mkTick' handles floating of tick `t` *into* the expression.
+ mkTick' :: CoreExpr -> CoreExpr
+ mkTick' expr = case expr of
Tick t2 e
- | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr
- -- Otherwise we assume that ticks of different placements float
- -- through each other.
- | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e
+ -- Common up ticks when possible, including profiling ticks that
+ -- share a cost centre and source notes that subsume one another.
+ | Just t' <- combineTickish_maybe t t2
+ -> mkTick t' e
- -- For annotations this is where we make sure to not introduce
- -- redundant ticks.
- | tickishContains t t2 -> mkTick' rest e -- Drop t2
- | tickishContains t2 t -> rest e -- Drop t
- | otherwise -> mkTick' (rest . Tick t2) e
+ -- Profiling ticks for different cost centres should never be reordered
+ -- relative to each other. Therefore, we stop whenever two collide.
+ | ProfNote {} <- t
+ , ProfNote {} <- t2
+ -> stop_here expr
- -- Ticks don't care about types, so we just float all ticks
- -- through them. Note that it's not enough to check for these
- -- cases top-level. While mkTick will never produce Core with type
- -- expressions below ticks, such constructs can be the result of
- -- unfoldings. We therefore make an effort to put everything into
- -- the right place no matter what we start with.
- Cast e co -> mkCast (mkTick' rest e) co
- Coercion co -> Tick t $ rest (Coercion co)
+ -- Ticks of different placements float through each other, so that each
+ -- tick can be floated into its expected position in the AST.
+ -- See Note [Tickish placement] in GHC.Types.Tickish.
+ | tickishPlace t2 /= tickishPlace t
+ -> Tick t2 $ mkTick' e
+
+ | otherwise
+ -> stop_here expr -- Always safe
Lam x e
-- Always float through type lambdas. Even for non-type lambdas,
-- floating is allowed for all but the most strict placement rule.
| not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
- -> Lam x $ mkTick' rest e
+ -> Lam x $ mkTick' e
- -- If it is both counting and scoped, we split the tick into its
- -- two components, often allowing us to keep the counting tick on
- -- the outside of the lambda and push the scoped tick inside.
- -- The point of this is that the counting tick can probably be
- -- floated, and the lambda may then be in a position to be
- -- beta-reduced.
- | canSplit
- -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
+ -- Push SCCs into lambdas.
+ -- See PSCC2 in Note [Pushing SCCs inwards].
+ | can_split
+ -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e
App f arg
- -- Always float through type applications.
+ -- All ticks float inwards through non-runtime arguments, as per
+ -- Note [Tickish placement] in GHC.Types.Tickish.
| not (isRuntimeArg arg)
- -> App (mkTick' rest f) arg
+ -> App (mkTick' f) arg
- -- We can also float through constructor applications, placement
- -- permitting. Again we can split.
- | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
+ -- Push SCCs into saturated constructor applications.
+ -- See PSCC3 in Note [Pushing SCCs inwards].
+ | isSaturatedConApp expr
+ , tickishPlace t == PlaceCostCentre || can_split
-> if tickishPlace t == PlaceCostCentre
- then rest $ tickHNFArgs t expr
- else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
+ then tickHNFArgs t expr
+ else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr
+
+ -- Ticks don't care about types, so we just float all ticks
+ -- through them. Note that it's not enough to check for these
+ -- cases at the top-level. While mkTick will never produce Core with type
+ -- expressions below ticks, such constructs can be the result of
+ -- unfoldings. We therefore make an effort to put everything into
+ -- the right place no matter what we start with.
+ Cast e co -> mkCast (mkTick' e) co
+
+ -- Float ticks into 'unsafeCoerce' the same way we would do with a cast.
+ Case scrut bndr ty alts@[Alt ac abs _rhs]
+ | Just rhs <- isUnsafeEqualityCase scrut bndr alts
+ -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)]
Var x
- | notFunction && tickishPlace t == PlaceCostCentre
- -> rest expr -- Drop t
- | notFunction && canSplit
- -> Tick (mkNoScope t) $ rest expr
+ -- Drop SCCs around non-function variables.
+ -- See PSCC1 in Note [Pushing SCCs inwards].
+ | notFunction
+ -- Does the tick `t` contain an SCC we can drop?
+ , tickishPlace t == PlaceCostCentre || can_split
+ -> if tickishPlace t == PlaceCostCentre
+ then expr -- Drop pure SCC ticks: scc<foo> (x :: Int) ==> x
+ else
+ -- Drop the scoping part of the tick, but keep the counting part.
+ Tick (mkNoScope t) expr
where
- -- SCCs can be eliminated on variables provided the variable
- -- is not a function. In these cases the SCC makes no difference:
- -- the cost of evaluating the variable will be attributed to its
- -- definition site. When the variable refers to a function, however,
- -- an SCC annotation on the variable affects the cost-centre stack
- -- when the function is called, so we must retain those.
notFunction = not (isFunTy (idType x))
- Lit{}
- | tickishPlace t == PlaceCostCentre
- -> rest expr -- Drop t
+ -- It doesn't make sense to wrap static data (such as coercions, types and literals)
+ -- in a tick which compiles to code, as the code will never be run.
+ --
+ -- It is in fact actively harmful, because Core Lint will fail on a
+ -- coercion binding such as let co = <scc> (...), see #26941.
+ -- It makes more sense to discard the cost centre tick rather than weakening
+ -- Core Lint.
+ e@(Coercion {}) | tickishIsCode t -> e
+ e@(Type {}) | tickishIsCode t -> e
+ e@(Lit {}) | tickishIsCode t -> e
+
+ -- Catch-all: annotate where we stand.
+ -- In particular (but not only): Let, most Cases.
+ _any -> Tick t expr
+
+{- Note [Pushing SCCs inwards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre,
+as described in Note [Tickish placement] GHC.Types.Tickish):
+
+ PSCC1: SCCs around non-function variables can be eliminated.
+ The cost of evaluating the variable will be attributed to its definition
+ site, so the SCC makes no difference. Example:
+
+ scc<foo> (x :: Int) ==> x
- -- Catch-all: Annotate where we stand
- _any -> Tick t $ rest expr
+ NB: this is only valid when the variable is not a function. For example, in:
+
+ scc<foo> (f :: Int -> Int)
+
+ we must retain the cost centre annotation, as it affects the cost-centre
+ pointer when the function is called. Discarding the SCC in this case would
+ defeat the profiling mechanism entirely!
+
+ PSCC2: SCCs can be pushed into lambdas.
+
+ scc<foo> (\x -> e) ==> \x -> scc<foo> e
+
+ PSCC3: We can push SCCs into (saturated) constructor applications.
+ For example, for an arity 2 data constructor 'D':
+
+ scc<foo> (D e1 e2) ==> D (scc<foo> e1) (scc<foo> e2)
+
+Now, two kinds of ticks contain SCCs:
+
+ - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True)
+ - profiling ticks that both count and scope
+
+The above explanation deals with bare SCCs. When handling profiling ticks that
+both count and scope, we can split tick into two, so that the scoping part can
+be pushed inwards (or even discarded). Specifically, we perform the following
+transformations:
+
+ PSCC1: Drop the SCC around non-function variables, keeping only the counting
+ part:
+
+ scctick<foo> (x :: Int) ==> tick<foo> x
+
+ PSCC2: Push the SCC inside lambdas:
+
+ scctick<foo> (\x. e) ==> tick<foo> (\x. scc<foo> e)
+
+ NB: we must keep the counting part outside the lambda, in order to preserve
+ tick counter tallies – it would not be sound to push the counting part inside.
+
+ PSCC3: Push the SCC inside saturated contructor applications.
+
+ scctick<foo> (D e1 e2) ==> tick<foo> (D (scc<foo> e1) (scc<foo> e2))
+
+The benefit of these transformation is that the counting part, tick<foo>, can
+likely be floated out of the way, which may expose additional optimisation
+opportunities. For example:
+
+ (scctick<foo> (\x. e)) arg
+
+ ==>{PSCC2}
+
+ (tick<foo> (\x. scc<foo> e)) arg
+
+ ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope}
+
+ tick<foo> ((\x. scc<foo> e) arg)
+
+ ==>{beta reduction}
+
+ tick<foo> (let x = arg in scc<foo> e)
+-}
mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ticks expr = foldr mkTick expr ticks
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -17,6 +17,7 @@ module GHC.Types.Tickish (
TickishPlacement(..),
tickishPlace,
tickishContains,
+ combineTickish_maybe,
-- * Breakpoint tick identifiers
BreakpointId(..), BreakTickIndex
@@ -261,8 +262,12 @@ Ticks have two independent attributes:
See Note [Scoped ticks]
+Note that profiling notes which both count and scope can be split into two
+separate ticks, one that counts and doesn't scope and one that scopes and doesn't
+count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'.
+
Note [Counting ticks]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~
The following ticks count:
- ProfNote ticks with profNoteCounts = True
- HPC ticks
@@ -290,7 +295,7 @@ sharing, so in practice the actual number of ticks may vary, except
that we never change the value from zero to non-zero or vice-versa.
Note [Scoped ticks]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~
The following ticks are scoped:
- ProfNote ticks with profNoteScope = True
- Breakpoints
@@ -375,6 +380,44 @@ Whether we are allowed to float in additional cost depends on the tick:
While these transformations are legal, we want to make a best effort to
only make use of them where it exposes transformation opportunities.
+
+Note [Tickish placement]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The placement behaviour of ticks (i.e. which terms we want the tick to be placed
+around in the AST) is governed by 'TickishPlacement'. We generally try to push
+ticks inwards until they end up placed around the kind of term expected by their
+placement rules.
+
+From most restrictive to least restrictive placement rules:
+
+ - PlaceRuntime: counting ticks.
+
+ Ticks with 'PlaceRuntime' placement want to be placed on run-time expressions.
+ They can be moved through pure compile-time constructs such as other ticks,
+ casts or type lambdas.
+
+ This is the most restrictive placement rule for ticks, as all tickishs have
+ in common that they want to track runtime processes.
+
+ Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement.
+
+ - PlaceNonLam: source notes.
+
+ Like PlaceRuntime, but we can also float the tick through value lambdas.
+ This makes sense where there is little difference between annotating the
+ lambda and annotating the lambda's code.
+
+ - PlaceCostCentre: non-counting profiling ticks.
+
+ In addition to floating through lambdas, cost-centre style tickishs can also
+ be moved from constructors and non-function variables. For example:
+
+ let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
+
+ Neither the constructor application, the variable or the literal are likely
+ to have any cost worth mentioning. And even if 'y' names a thunk, the call
+ would not care about the evaluation context. Therefore, removing all
+ annotations in the above example is safe.
-}
-- | Returns @True@ for ticks that can be floated upwards easily even
@@ -441,35 +484,19 @@ isProfTick _ = False
-- annotating for example using @mkTick@. If we find that we want to
-- put a tickish on an expression ruled out here, we try to float it
-- inwards until we find a suitable expression.
+--
+-- See Note [Tickish placement].
data TickishPlacement =
- -- | Place ticks exactly on run-time expressions. We can still
- -- move the tick through pure compile-time constructs such as
- -- other ticks, casts or type lambdas. This is the most
- -- restrictive placement rule for ticks, as all tickishs have in
- -- common that they want to track runtime processes. The only
- -- legal placement rule for counting ticks.
- -- NB: We generally try to move these as close to the relevant
- -- runtime expression as possible. This means they get pushed through
- -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`.
+ -- | Place ticks exactly on run-time expressions, moving them through pure
+ -- compile-time constructs such as other ticks, casts or type lambdas.
PlaceRuntime
- -- | As @PlaceRuntime@, but we float the tick through all
- -- lambdas. This makes sense where there is little difference
- -- between annotating the lambda and annotating the lambda's code.
+ -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas.
| PlaceNonLam
- -- | In addition to floating through lambdas, cost-centre style
- -- tickishs can also be moved from constructors, non-function
- -- variables and literals. For example:
- --
- -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
- --
- -- Neither the constructor application, the variable or the
- -- literal are likely to have any cost worth mentioning. And even
- -- if y names a thunk, the call would not care about the
- -- evaluation context. Therefore removing all annotations in the
- -- above example is safe.
+ -- | As 'PlaceNonLam', but also float through constructors, non-function
+ -- variables and literals.
| PlaceCostCentre
deriving (Eq,Show)
@@ -477,7 +504,9 @@ data TickishPlacement =
instance Outputable TickishPlacement where
ppr = text . show
--- | Placement behaviour we want for the ticks
+-- | Placement behaviour we want for the ticks.
+--
+-- See Note [Tickish placement].
tickishPlace :: GenTickish pass -> TickishPlacement
tickishPlace n@ProfNote{}
| profNoteCount n = PlaceRuntime
@@ -486,6 +515,43 @@ tickishPlace HpcTick{} = PlaceRuntime
tickishPlace Breakpoint{} = PlaceRuntime
tickishPlace SourceNote{} = PlaceNonLam
+-- | Merge two ticks into one, if that is possible.
+--
+-- Examples:
+--
+-- - combine two source note ticks if one contains the other,
+-- - combine a non-counting profiling tick with a non-scoping profiling tick
+-- for the same cost centre
+-- - combine two equal breakpoint ticks or HPC ticks
+combineTickish_maybe :: Eq (GenTickish pass)
+ => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass)
+combineTickish_maybe
+ (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 })
+ (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 })
+ | cc1 == cc2
+ , not cnt1 || not cnt2
+ = Just $ ProfNote { profNoteCC = cc1
+ , profNoteCount = cnt1 || cnt2
+ , profNoteScope = scope1 || scope2
+ }
+combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2)
+ | n1 == n2
+ , sp1 `containsSpan` sp2
+ = Just t1
+ | n1 == n2
+ , sp2 `containsSpan` sp1
+ = Just t2
+ -- NB: it would be possible to use 'combineRealSrcSpans' instead,
+ -- but that has the risk of combining many source note ticks into a single
+ -- tick with a huge source span.
+combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {})
+ | t1 == t2
+ = Just t1
+combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {})
+ | t1 == t2
+ = Just t1
+combineTickish_maybe _ _ = Nothing
+
-- | Returns whether one tick "contains" the other one, therefore
-- making the second tick redundant.
tickishContains :: Eq (GenTickish pass)
=====================================
testsuite/tests/simplCore/should_compile/T26941.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T26941 where
+
+import GHC.TypeLits
+
+import T26941_aux ( SMayNat(SKnown), ListH, shxHead )
+
+shsHead :: ListH (Just n : sh) Int -> SNat n
+shsHead shx =
+ case shxHead shx of
+ SKnown SNat -> SNat
=====================================
testsuite/tests/simplCore/should_compile/T26941_aux.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T26941_aux where
+
+import Data.Kind
+import GHC.TypeLits
+
+shxHead :: ListH (n : sh) i -> SMayNat i n
+shxHead list = {-# SCC "bad_scc" #-}
+ ( case list of (i `ConsKnown` _) -> SKnown i )
+
+type ListH :: [Maybe Nat] -> Type -> Type
+data ListH sh i where
+ ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i
+
+data SMayNat i n where
+ SKnown :: SNat n -> SMayNat i (Just n)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -568,6 +568,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu
test('T26349', normal, compile, ['-O -ddump-rules'])
test('T26681', normal, compile, ['-O'])
+test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof'])
+
# T26709: we expect three `case` expressions not four
test('T26709', [grep_errmsg(r'case')],
multimod_compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a5b42add124307ec14f4e309f03840…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a5b42add124307ec14f4e309f03840…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] Avoid `panic` during `hscRecompStatus`
by Hannes Siebenhandl (＠fendor) 16 Mar '26
by Hannes Siebenhandl (＠fendor) 16 Mar '26
16 Mar '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
fb57793a by fendor at 2026-03-16T15:33:57+01:00
Avoid `panic` during `hscRecompStatus`
- - - - -
2 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Unit/Module/Status.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -865,7 +865,7 @@ hscRecompStatus
| otherwise -> do
-- Check the status of all the linkable types we might need.
-- 1. The in-memory linkable we had at hand.
- bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable)
+ bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable)
-- 2. The bytecode object file
bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary
-- 3. Bytecode from an interface's whole core bindings.
@@ -984,23 +984,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)
@@ -1013,7 +1012,7 @@ checkByteCodeFromObject hsc_env mod_sum = do
-- that the one we have on disk would be suitable as well.
linkable <- unsafeInterleaveIO $ do
bco <- ByteCode.readBinByteCode hsc_env obj_fn
- return $ mkModuleByteCodeLinkable obj_date bco
+ return $ mkOnlyModuleByteCodeLinkable obj_date bco
return $ UpToDateItem linkable
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -18,12 +18,11 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
-import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith, linkableModuleByteCodes )
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Stack.Types (HasCallStack)
-- | Status of a module in incremental compilation
data HscRecompStatus
@@ -84,14 +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 ->
- let
- mbc = expectSingletonGbcLinkable lm
- in
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just mbc) }
+ Left lm -> emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -99,20 +93,11 @@ 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 ->
- let
- mbc = expectSingletonGbcLinkable bc
- in
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- $ RecompLinkables (NormalLinkable (Just mbc)) (Just o)
+ assertPpr (linkableIsNativeCodeOnly o) (ppr o)
+ $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
-
-expectSingletonGbcLinkable :: HasCallStack => Linkable -> LinkableWith ModuleByteCode
-expectSingletonGbcLinkable lm = case linkableModuleByteCodes lm of
- [] -> pprPanic "Expected 1 DotGBC in Linkable" (ppr lm)
- [mbc] -> mbc <$ lm
- _ -> pprPanic "Expected 1 DotGBC in Linkable" (ppr lm)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb57793ae31c0ae06ae986752c7c9ec…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb57793ae31c0ae06ae986752c7c9ec…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] Record `LinkableUsage` instead of `Linkable` in `LoaderState`
by Hannes Siebenhandl (＠fendor) 16 Mar '26
by Hannes Siebenhandl (＠fendor) 16 Mar '26
16 Mar '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
5e882bb0 by fendor at 2026-03-16T15:21:35+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.
-------------------------
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.
- - - - -
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
=====================================
@@ -0,0 +1,293 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Binary (
+ -- * ByteCode objects on disk and intermediate representations
+ OnDiskModuleByteCode(..),
+ BytecodeLibX(..),
+ BytecodeLib,
+ OnDiskBytecodeLib,
+ InterpreterLibrary(..),
+ InterpreterLibraryContents(..),
+ -- * Binary 'Name' serializers
+ BytecodeNameEnv(..),
+ addBinNameWriter,
+ addBinNameReader,
+) where
+
+import GHC.Prelude
+
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.Name.Env
+import GHC.Types.SrcLoc
+import GHC.Unit.Types
+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
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+-- | The on-disk representation of a bytecode object for a specific module.
+--
+-- This is the representation which we serialise and write to disk.
+-- The difference from 'ModuleByteCode' is that the contents of the object files
+-- 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
+ }
+
+type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents)
+
+instance Outputable a => Outputable (BytecodeLibX a) where
+ ppr (BytecodeLib {..}) = vcat [
+ (text "BytecodeLib" <+> ppr bytecodeLibUnitId),
+ (text "Files" <+> ppr bytecodeLibFiles),
+ (text "Foreign" <+> ppr bytecodeLibForeign) ]
+
+type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)
+
+-- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
+data BytecodeLibX a = BytecodeLib {
+ bytecodeLibUnitId :: UnitId,
+ bytecodeLibFiles :: [CompiledByteCode],
+ bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
+}
+
+data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String }
+ | InterpreterStaticObjects { getStaticObjects :: [FilePath] }
+
+
+instance Outputable InterpreterLibrary where
+ ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name
+ ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths)
+
+
+data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString }
+ | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] }
+
+instance Binary InterpreterLibraryContents where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> InterpreterLibrarySharedContents <$> get bh
+ 1 -> InterpreterLibraryStaticContents <$> get bh
+ _ -> panic "Binary InterpreterLibraryContents: invalid byte"
+ put_ bh (InterpreterLibrarySharedContents contents) = do
+ putByte bh 0
+ put_ bh contents
+ put_ bh (InterpreterLibraryStaticContents contents) = do
+ 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 <- get bh
+ odgbc_foreign <- get bh
+ pure OnDiskModuleByteCode {..}
+
+ put_ bh OnDiskModuleByteCode {..} = do
+ put_ bh odgbc_hash
+ put_ bh odgbc_module
+ put_ bh odgbc_compiled_byte_code
+ put_ bh odgbc_foreign
+
+instance Binary OnDiskBytecodeLib where
+ get bh = do
+ bytecodeLibUnitId <- get bh
+ bytecodeLibFiles <- get bh
+ bytecodeLibForeign <- get bh
+ pure BytecodeLib {..}
+
+ put_ bh BytecodeLib {..} = do
+ put_ bh bytecodeLibUnitId
+ put_ bh bytecodeLibFiles
+ put_ bh bytecodeLibForeign
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaBinName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ return $
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaBinName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaBinName bh
+ <*> get bh
+ <*> (Binary.decode <$> get bh)
+ <*> (Binary.decode <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaBinName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaBinName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ 3 -> BCOPtrBreakArray <$> get bh
+ _ -> panic "Binary BCOPtr: invalid byte"
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaBinName bh
+ 3 -> BCONPtrAddr <$> getViaBinName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ 7 -> BCONPtrCostCentre <$> get bh
+ _ -> panic "Binary BCONPtr: invalid byte"
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+newtype BinName = BinName {unBinName :: Name}
+
+getViaBinName :: ReadBinHandle -> IO Name
+getViaBinName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unBinName <$> f bh
+
+putViaBinName :: WriteBinHandle -> Name -> IO ()
+putViaBinName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ BinName nm
+
+-- | NameEnv for serialising Names in 'CompiledByteCode'.
+--
+-- See Note [Serializing Names in bytecode]
+
+data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64
+ , _bytecode_name_subst :: NameEnv Word64
+ }
+
+addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addBinNameWriter bh' = do
+ env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv)
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (BinName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ key <- getBinNameKey env_ref nm
+ -- Delimit the OccName from the deterministic counter to keep the
+ -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
+ put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
+ where
+ -- Find a deterministic key for local names. This
+ getBinNameKey ref name = do
+ atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) ->
+ case lookupNameEnv subst name of
+ Just idx -> (b, idx)
+ Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
+
+addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
+addBinNameReader nc bh' = do
+ env_ref <- newIORef emptyOccEnv
+ pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ pure $ BinName nm
+ 1 -> do
+ occ <- mkVarOccFS <$> get bh
+ -- We don't want to get a new unique from the NameCache each time we
+ -- see a name.
+ nm' <- unsafeInterleaveIO $ do
+ u <- takeUniqFromNameCache nc
+ evaluate $ mkInternalName u occ noSrcSpan
+ fmap BinName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> nm' `seq` (extendOccEnv env occ nm', nm')
+ _ -> panic "Binary BinName: invalid byte"
+
+-- Note [Serializing Names in bytecode]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The bytecode related types contain various Names which we need to
+-- serialize. Unfortunately, we can't directly use the Binary instance
+-- of Name: it is only meant to be used for serializing external Names
+-- in BinIface logic, but bytecode does contain internal Names.
+--
+-- We also need to maintain the invariant that: any pair of internal
+-- Names with equal/different uniques must also be deserialized to
+-- have the same equality. Therefore when we write the names to the interface, we
+-- use an incrementing counter to give each local name it's own unique number. A substitution
+-- is maintained to give each occurence of the Name the same unique key. When the interface
+-- is read, a reverse mapping is used from these unique keys to a Name.
+--
=====================================
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,41 +14,34 @@ module GHC.ByteCode.Serialize
, InterpreterLibraryContents(..)
, writeBytecodeLib
, readBytecodeLib
+ , mkModuleByteCode
+ , fingerprintModuleByteCodeContents
, decodeOnDiskModuleByteCode
, decodeOnDiskBytecodeLib
)
where
-import Control.Monad
-import Data.Binary qualified as Binary
-import Data.Foldable
-import Data.IORef
-import Data.Proxy
-import Data.Word
+import GHC.Prelude
+
+import GHC.ByteCode.Binary
import GHC.ByteCode.Types
-import GHC.Data.FastString
+import GHC.ByteCode.Recomp.Binary (computeFingerprint)
+import Data.ByteString (ByteString)
import GHC.Driver.Env
+import GHC.Driver.DynFlags
import GHC.Iface.Binary
-import GHC.Prelude
-import GHC.Types.Name
-import GHC.Types.Name.Cache
-import GHC.Types.SrcLoc
+import GHC.Iface.Recomp.Binary (putNameLiterally)
+import GHC.Linker.Types
+import GHC.Unit.Types
import GHC.Utils.Binary
-import GHC.Utils.Exception
-import GHC.Utils.Panic
import GHC.Utils.TmpFs
-import System.FilePath
-import GHC.Unit.Types
-import GHC.Driver.DynFlags
-import System.Directory
-import Data.ByteString (ByteString)
+import GHC.Utils.Logger
+import GHC.Utils.Fingerprint (Fingerprint)
+
import qualified Data.ByteString as BS
import Data.Traversable
-import GHC.Utils.Logger
-import GHC.Linker.Types
-import System.IO.Unsafe (unsafeInterleaveIO)
-import GHC.Utils.Outputable
-import GHC.Types.Name.Env
+import System.Directory
+import System.FilePath
{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -88,74 +81,6 @@ See Note [Recompilation avoidance with bytecode objects]
-}
--- | The on-disk representation of a bytecode object for a specific module.
---
--- This is the representation which we serialise and write to disk.
--- The difference from 'ModuleByteCode' is that the contents of the object files
--- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
--- temporary files.
-data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module
- , odgbc_compiled_byte_code :: CompiledByteCode
- , odgbc_foreign :: [ByteString] -- ^ Contents of object files
- }
-
-type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents)
-
-instance Outputable a => Outputable (BytecodeLibX a) where
- ppr (BytecodeLib {..}) = vcat [
- (text "BytecodeLib" <+> ppr bytecodeLibUnitId),
- (text "Files" <+> ppr bytecodeLibFiles),
- (text "Foreign" <+> ppr bytecodeLibForeign) ]
-
-type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)
-
--- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
-data BytecodeLibX a = BytecodeLib {
- bytecodeLibUnitId :: UnitId,
- bytecodeLibFiles :: [CompiledByteCode],
- bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
-}
-
-data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String }
- | InterpreterStaticObjects { getStaticObjects :: [FilePath] }
-
-
-instance Outputable InterpreterLibrary where
- ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name
- ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths)
-
-
-data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString }
- | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] }
-
-instance Binary InterpreterLibraryContents where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> InterpreterLibrarySharedContents <$> get bh
- 1 -> InterpreterLibraryStaticContents <$> get bh
- _ -> panic "Binary InterpreterLibraryContents: invalid byte"
- put_ bh (InterpreterLibrarySharedContents contents) = do
- putByte bh 0
- put_ bh contents
- put_ bh (InterpreterLibraryStaticContents contents) = do
- putByte bh 1
- put_ bh contents
-
-instance Binary OnDiskBytecodeLib where
- get bh = do
- bytecodeLibUnitId <- get bh
- bytecodeLibFiles <- get bh
- bytecodeLibForeign <- get bh
- pure BytecodeLib {..}
-
- put_ bh BytecodeLib {..} = do
- put_ bh bytecodeLibUnitId
- put_ bh bytecodeLibFiles
- put_ bh bytecodeLibForeign
-
-
-
writeBytecodeLib :: BytecodeLib -> FilePath -> IO ()
writeBytecodeLib lib path = do
odbco <- encodeBytecodeLib lib
@@ -168,22 +93,10 @@ 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
-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
-
-- | Convert an 'OnDiskModuleByteCode' to an 'ModuleByteCode'.
-- 'OnDiskModuleByteCode' is the representation which we read from a file,
-- the 'ModuleByteCode' is the representation which is manipulated by program logic.
@@ -198,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
@@ -257,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.
@@ -269,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.
@@ -282,169 +197,12 @@ writeBinByteCode f cbc = do
putWithUserData QuietBinIFace NormalCompression bh odbco
writeBinMem bh f
-instance Binary CompiledByteCode where
- get bh = do
- bc_bcos <- get bh
- bc_itbls_len <- get bh
- bc_itbls <- replicateM bc_itbls_len $ do
- nm <- getViaBinName bh
- itbl <- get bh
- pure (nm, itbl)
- bc_strs_len <- get bh
- bc_strs <-
- replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
- bc_breaks <- get bh
- bc_spt_entries <- get bh
- return $
- CompiledByteCode
- { bc_bcos,
- bc_itbls,
- bc_strs,
- bc_breaks,
- bc_spt_entries
- }
-
- put_ bh CompiledByteCode {..} = do
- put_ bh bc_bcos
- put_ bh $ length bc_itbls
- for_ bc_itbls $ \(nm, itbl) -> do
- putViaBinName bh nm
- put_ bh itbl
- put_ bh $ length bc_strs
- for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
- put_ bh bc_breaks
- put_ bh bc_spt_entries
-
-instance Binary UnlinkedBCO where
- get bh =
- UnlinkedBCO
- <$> getViaBinName bh
- <*> get bh
- <*> (Binary.decode <$> get bh)
- <*> (Binary.decode <$> get bh)
- <*> get bh
- <*> get bh
-
- put_ bh UnlinkedBCO {..} = do
- putViaBinName bh unlinkedBCOName
- put_ bh unlinkedBCOArity
- put_ bh $ Binary.encode unlinkedBCOInstrs
- put_ bh $ Binary.encode unlinkedBCOBitmap
- put_ bh unlinkedBCOLits
- put_ bh unlinkedBCOPtrs
+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
-instance Binary BCOPtr where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> BCOPtrName <$> getViaBinName bh
- 1 -> BCOPtrPrimOp <$> get bh
- 2 -> BCOPtrBCO <$> get bh
- 3 -> BCOPtrBreakArray <$> get bh
- _ -> panic "Binary BCOPtr: invalid byte"
-
- put_ bh ptr = case ptr of
- BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm
- BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
- BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
- BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
-
-instance Binary BCONPtr where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
- 1 -> BCONPtrLbl <$> get bh
- 2 -> BCONPtrItbl <$> getViaBinName bh
- 3 -> BCONPtrAddr <$> getViaBinName bh
- 4 -> BCONPtrStr <$> get bh
- 5 -> BCONPtrFS <$> get bh
- 6 -> BCONPtrFFIInfo <$> get bh
- 7 -> BCONPtrCostCentre <$> get bh
- _ -> panic "Binary BCONPtr: invalid byte"
-
- put_ bh ptr = case ptr of
- BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
- BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
- BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm
- BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm
- BCONPtrStr str -> putByte bh 4 *> put_ bh str
- BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
- BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
- BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
-
-newtype BinName = BinName {unBinName :: Name}
-
-getViaBinName :: ReadBinHandle -> IO Name
-getViaBinName bh = case findUserDataReader Proxy bh of
- BinaryReader f -> unBinName <$> f bh
-
-putViaBinName :: WriteBinHandle -> Name -> IO ()
-putViaBinName bh nm = case findUserDataWriter Proxy bh of
- BinaryWriter f -> f bh $ BinName nm
-
-data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64
- , _bytecode_name_subst :: NameEnv Word64
- }
-
-addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
-addBinNameWriter bh' = do
- env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv)
- evaluate
- $ flip addWriterToUserData bh'
- $ BinaryWriter
- $ \bh (BinName nm) ->
- if
- | isExternalName nm -> do
- putByte bh 0
- put_ bh nm
- | otherwise -> do
- putByte bh 1
- key <- getBinNameKey env_ref nm
- -- Delimit the OccName from the deterministic counter to keep the
- -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
- put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
- where
- -- Find a deterministic key for local names. This
- getBinNameKey ref name = do
- atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) ->
- case lookupNameEnv subst name of
- Just idx -> (b, idx)
- Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
-
-addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
-addBinNameReader HscEnv {..} bh' = do
- env_ref <- newIORef emptyOccEnv
- pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
- t <- getByte bh
- case t of
- 0 -> do
- nm <- get bh
- pure $ BinName nm
- 1 -> do
- occ <- mkVarOccFS <$> get bh
- -- 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
- evaluate $ mkInternalName u occ noSrcSpan
- fmap BinName $ atomicModifyIORef' env_ref $ \env ->
- case lookupOccEnv env occ of
- Just nm -> (env, nm)
- _ -> nm' `seq` (extendOccEnv env occ nm', nm')
- _ -> panic "Binary BinName: invalid byte"
-
--- Note [Serializing Names in bytecode]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The bytecode related types contain various Names which we need to
--- serialize. Unfortunately, we can't directly use the Binary instance
--- of Name: it is only meant to be used for serializing external Names
--- in BinIface logic, but bytecode does contain internal Names.
---
--- We also need to maintain the invariant that: any pair of internal
--- Names with equal/different uniques must also be deserialized to
--- have the same equality. Therefore when we write the names to the interface, we
--- use an incrementing counter to give each local name it's own unique number. A substitution
--- is maintained to give each occurence of the Name the same unique key. When the interface
--- is read, a reverse mapping is used from these unique keys to a Name.
---
+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
=====================================
@@ -301,8 +301,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
{- **********************************************************************
%* *
@@ -866,7 +865,7 @@ hscRecompStatus
| otherwise -> do
-- Check the status of all the linkable types we might need.
-- 1. The in-memory linkable we had at hand.
- bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable)
+ bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable)
-- 2. The bytecode object file
bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary
-- 3. Bytecode from an interface's whole core bindings.
@@ -1013,7 +1012,7 @@ 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
+ bco <- ByteCode.readBinByteCode hsc_env obj_fn
return $ mkModuleByteCodeLinkable obj_date bco
return $ UpToDateItem linkable
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
@@ -1098,7 +1097,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
@@ -1106,8 +1105,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)
@@ -1148,14 +1148,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.
--
@@ -2217,7 +2217,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
{-
@@ -2232,20 +2232,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
@@ -2767,13 +2767,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?
@@ -2859,8 +2859,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 -}
@@ -2876,7 +2877,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
@@ -225,6 +230,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"
@@ -718,6 +724,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
@@ -739,6 +754,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.
@@ -760,14 +796,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,
@@ -1032,19 +1068,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
=====================================
@@ -228,7 +228,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
@@ -258,7 +258,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
@@ -645,7 +645,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)
@@ -659,19 +659,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
@@ -723,7 +718,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
@@ -823,7 +818,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
@@ -952,17 +947,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
{- **********************************************************************
@@ -1115,7 +1110,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,
@@ -1125,7 +1120,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
@@ -1133,7 +1128,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,11 +18,12 @@ 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, linkableModuleByteCodes )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Stack.Types (HasCallStack)
-- | Status of a module in incremental compilation
data HscRecompStatus
@@ -59,7 +60,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
@@ -86,8 +87,11 @@ safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable
justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
justBytecode = \case
Left lm ->
+ let
+ mbc = expectSingletonGbcLinkable lm
+ in
assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just mbc) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -98,8 +102,17 @@ justObjects lm =
bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
bytecodeAndObjects either_bc o = case either_bc of
Left bc ->
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ let
+ mbc = expectSingletonGbcLinkable bc
+ in
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ $ RecompLinkables (NormalLinkable (Just mbc)) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
+
+expectSingletonGbcLinkable :: HasCallStack => Linkable -> LinkableWith ModuleByteCode
+expectSingletonGbcLinkable lm = case linkableModuleByteCodes lm of
+ [] -> pprPanic "Expected 1 DotGBC in Linkable" (ppr lm)
+ [mbc] -> mbc <$ lm
+ _ -> pprPanic "Expected 1 DotGBC in Linkable" (ppr lm)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -210,10 +210,12 @@ Library
GHC.Builtin.Uniques
GHC.Builtin.Utils
GHC.ByteCode.Asm
+ GHC.ByteCode.Binary
GHC.ByteCode.Breakpoints
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/-/commit/5e882bb069388d3b6525bddf5d5d269…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e882bb069388d3b6525bddf5d5d269…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bump-submodules-2603] 5 commits: Configure: Fix check for --target support in stage0 CC
by Cheng Shao (＠TerrorJack) 16 Mar '26
by Cheng Shao (＠TerrorJack) 16 Mar '26
16 Mar '26
Cheng Shao pushed to branch wip/bump-submodules-2603 at Glasgow Haskell Compiler / GHC
Commits:
43638643 by Andreas Klebinger at 2026-03-15T18:15:48-04:00
Configure: Fix check for --target support in stage0 CC
The check FP_PROG_CC_LINKER_TARGET used $CC unconditionally to check for
--target support. However this fails for the stage0 config where the C
compiler used is not $CC but $CC_STAGE0.
Since we already pass the compiler under test into the macro I simply
changed it to use that instead.
Fixes #26999
- - - - -
18fd0df6 by Simon Hengel at 2026-03-15T18:16:33-04:00
Fix typo in recursive_do.rst
- - - - -
ab10d72d by Cheng Shao at 2026-03-16T14:06:11+00:00
hadrian: add thLift/thQuasiquoter to toolTargets
This commit adds missing `thLift`/`thQuasiquoter` to hadrian
`toolTargets` to keep in sync with `stage0packages`. This is now
required when os-string/filepath is updated to include them as
dependencies.
- - - - -
e1cd5fad by Cheng Shao at 2026-03-16T14:06:11+00:00
libraries: bump os-string submodule to 2.0.10
- - - - -
ff440778 by Cheng Shao at 2026-03-16T14:06:11+00:00
libraries: bump filepath submodule to 1.5.5.0
- - - - -
5 changed files:
- docs/users_guide/exts/recursive_do.rst
- hadrian/src/Rules/ToolArgs.hs
- libraries/filepath
- libraries/os-string
- m4/fp_prog_cc_linker_target.m4
Changes:
=====================================
docs/users_guide/exts/recursive_do.rst
=====================================
@@ -56,7 +56,7 @@ or equivalently
As you can guess ``justOnes`` will evaluate to ``Just [-1,-1,-1,...``.
-GHC's implementation the mdo-notation closely follows the original
+GHC's implementation of the mdo-notation closely follows the original
translation as described in the paper `A recursive do for
Haskell <https://leventerkok.github.io/papers/recdo.pdf>`__, which
in turn is based on the work `Value Recursion in Monadic
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -153,6 +153,9 @@ toolTargets = [ cabalSyntax
, filepath
, fileio
, osString
+ -- os-string/filepath now depend on them
+ , thLift
+ , thQuasiquoter
-- , ghc -- # depends on ghc library
-- , runGhc -- # depends on ghc library
, ghcBoot
@@ -200,4 +203,3 @@ dirMap = do
cd <- readContextData c
ids <- liftIO $ mapM canonicalizePath [pkgPath p </> i | i <- srcDirs cd]
return $ map (,(p, modules cd ++ otherModules cd)) ids
-
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit baac7d7e76449f76fc6785e77206edb5530b6bfb
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit c08666bf7bf528e607fc1eacc20032ec59e69df3
+Subproject commit 71f66e1af2288867becaa567dfb10c1d791b0343
=====================================
m4/fp_prog_cc_linker_target.m4
=====================================
@@ -8,7 +8,7 @@
# a linker
AC_DEFUN([FP_PROG_CC_LINKER_TARGET],
[
- AC_MSG_CHECKING([whether $CC used as a linker understands --target])
+ AC_MSG_CHECKING([whether $1 used as a linker understands --target])
echo 'int foo() { return 0; }' > conftest1.c
echo 'int main() { return 0; }' > conftest2.c
@@ -20,7 +20,7 @@ AC_DEFUN([FP_PROG_CC_LINKER_TARGET],
# See Note [Don't pass --target to emscripten toolchain] in GHC.Toolchain.Program
CONF_CC_SUPPORTS_TARGET=NO
AC_MSG_RESULT([no])
- elif "$CC" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o;
+ elif "$1" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o;
then
$3="--target=$LlvmTarget $$3"
AC_MSG_RESULT([yes])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b6ace16cff80e9b548519ee658bdb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b6ace16cff80e9b548519ee658bdb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] Record `LinkableUsage` instead of `Linkable` in `LoaderState`
by Hannes Siebenhandl (＠fendor) 16 Mar '26
by Hannes Siebenhandl (＠fendor) 16 Mar '26
16 Mar '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
31a3cbc3 by fendor at 2026-03-16T14:56:24+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.
-------------------------
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.
- - - - -
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
=====================================
@@ -0,0 +1,293 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Binary (
+ -- * ByteCode objects on disk and intermediate representations
+ OnDiskModuleByteCode(..),
+ BytecodeLibX(..),
+ BytecodeLib,
+ OnDiskBytecodeLib,
+ InterpreterLibrary(..),
+ InterpreterLibraryContents(..),
+ -- * Binary 'Name' serializers
+ BytecodeNameEnv(..),
+ addBinNameWriter,
+ addBinNameReader,
+) where
+
+import GHC.Prelude
+
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.Name.Env
+import GHC.Types.SrcLoc
+import GHC.Unit.Types
+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
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+-- | The on-disk representation of a bytecode object for a specific module.
+--
+-- This is the representation which we serialise and write to disk.
+-- The difference from 'ModuleByteCode' is that the contents of the object files
+-- 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
+ }
+
+type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents)
+
+instance Outputable a => Outputable (BytecodeLibX a) where
+ ppr (BytecodeLib {..}) = vcat [
+ (text "BytecodeLib" <+> ppr bytecodeLibUnitId),
+ (text "Files" <+> ppr bytecodeLibFiles),
+ (text "Foreign" <+> ppr bytecodeLibForeign) ]
+
+type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)
+
+-- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
+data BytecodeLibX a = BytecodeLib {
+ bytecodeLibUnitId :: UnitId,
+ bytecodeLibFiles :: [CompiledByteCode],
+ bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
+}
+
+data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String }
+ | InterpreterStaticObjects { getStaticObjects :: [FilePath] }
+
+
+instance Outputable InterpreterLibrary where
+ ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name
+ ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths)
+
+
+data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString }
+ | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] }
+
+instance Binary InterpreterLibraryContents where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> InterpreterLibrarySharedContents <$> get bh
+ 1 -> InterpreterLibraryStaticContents <$> get bh
+ _ -> panic "Binary InterpreterLibraryContents: invalid byte"
+ put_ bh (InterpreterLibrarySharedContents contents) = do
+ putByte bh 0
+ put_ bh contents
+ put_ bh (InterpreterLibraryStaticContents contents) = do
+ 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 <- get bh
+ odgbc_foreign <- get bh
+ pure OnDiskModuleByteCode {..}
+
+ put_ bh OnDiskModuleByteCode {..} = do
+ put_ bh odgbc_hash
+ put_ bh odgbc_module
+ put_ bh odgbc_compiled_byte_code
+ put_ bh odgbc_foreign
+
+instance Binary OnDiskBytecodeLib where
+ get bh = do
+ bytecodeLibUnitId <- get bh
+ bytecodeLibFiles <- get bh
+ bytecodeLibForeign <- get bh
+ pure BytecodeLib {..}
+
+ put_ bh BytecodeLib {..} = do
+ put_ bh bytecodeLibUnitId
+ put_ bh bytecodeLibFiles
+ put_ bh bytecodeLibForeign
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaBinName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ return $
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaBinName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaBinName bh
+ <*> get bh
+ <*> (Binary.decode <$> get bh)
+ <*> (Binary.decode <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaBinName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaBinName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ 3 -> BCOPtrBreakArray <$> get bh
+ _ -> panic "Binary BCOPtr: invalid byte"
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaBinName bh
+ 3 -> BCONPtrAddr <$> getViaBinName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ 7 -> BCONPtrCostCentre <$> get bh
+ _ -> panic "Binary BCONPtr: invalid byte"
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+newtype BinName = BinName {unBinName :: Name}
+
+getViaBinName :: ReadBinHandle -> IO Name
+getViaBinName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unBinName <$> f bh
+
+putViaBinName :: WriteBinHandle -> Name -> IO ()
+putViaBinName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ BinName nm
+
+-- | NameEnv for serialising Names in 'CompiledByteCode'.
+--
+-- See Note [Serializing Names in bytecode]
+
+data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64
+ , _bytecode_name_subst :: NameEnv Word64
+ }
+
+addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addBinNameWriter bh' = do
+ env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv)
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (BinName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ key <- getBinNameKey env_ref nm
+ -- Delimit the OccName from the deterministic counter to keep the
+ -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
+ put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
+ where
+ -- Find a deterministic key for local names. This
+ getBinNameKey ref name = do
+ atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) ->
+ case lookupNameEnv subst name of
+ Just idx -> (b, idx)
+ Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
+
+addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
+addBinNameReader nc bh' = do
+ env_ref <- newIORef emptyOccEnv
+ pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ pure $ BinName nm
+ 1 -> do
+ occ <- mkVarOccFS <$> get bh
+ -- We don't want to get a new unique from the NameCache each time we
+ -- see a name.
+ nm' <- unsafeInterleaveIO $ do
+ u <- takeUniqFromNameCache nc
+ evaluate $ mkInternalName u occ noSrcSpan
+ fmap BinName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> nm' `seq` (extendOccEnv env occ nm', nm')
+ _ -> panic "Binary BinName: invalid byte"
+
+-- Note [Serializing Names in bytecode]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The bytecode related types contain various Names which we need to
+-- serialize. Unfortunately, we can't directly use the Binary instance
+-- of Name: it is only meant to be used for serializing external Names
+-- in BinIface logic, but bytecode does contain internal Names.
+--
+-- We also need to maintain the invariant that: any pair of internal
+-- Names with equal/different uniques must also be deserialized to
+-- have the same equality. Therefore when we write the names to the interface, we
+-- use an incrementing counter to give each local name it's own unique number. A substitution
+-- is maintained to give each occurence of the Name the same unique key. When the interface
+-- is read, a reverse mapping is used from these unique keys to a Name.
+--
=====================================
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,41 +14,34 @@ module GHC.ByteCode.Serialize
, InterpreterLibraryContents(..)
, writeBytecodeLib
, readBytecodeLib
+ , mkModuleByteCode
+ , fingerprintModuleByteCodeContents
, decodeOnDiskModuleByteCode
, decodeOnDiskBytecodeLib
)
where
-import Control.Monad
-import Data.Binary qualified as Binary
-import Data.Foldable
-import Data.IORef
-import Data.Proxy
-import Data.Word
+import GHC.Prelude
+
+import GHC.ByteCode.Binary
import GHC.ByteCode.Types
-import GHC.Data.FastString
+import GHC.ByteCode.Recomp.Binary (computeFingerprint)
+import Data.ByteString (ByteString)
import GHC.Driver.Env
+import GHC.Driver.DynFlags
import GHC.Iface.Binary
-import GHC.Prelude
-import GHC.Types.Name
-import GHC.Types.Name.Cache
-import GHC.Types.SrcLoc
+import GHC.Iface.Recomp.Binary (putNameLiterally)
+import GHC.Linker.Types
+import GHC.Unit.Types
import GHC.Utils.Binary
-import GHC.Utils.Exception
-import GHC.Utils.Panic
import GHC.Utils.TmpFs
-import System.FilePath
-import GHC.Unit.Types
-import GHC.Driver.DynFlags
-import System.Directory
-import Data.ByteString (ByteString)
+import GHC.Utils.Logger
+import GHC.Utils.Fingerprint (Fingerprint)
+
import qualified Data.ByteString as BS
import Data.Traversable
-import GHC.Utils.Logger
-import GHC.Linker.Types
-import System.IO.Unsafe (unsafeInterleaveIO)
-import GHC.Utils.Outputable
-import GHC.Types.Name.Env
+import System.Directory
+import System.FilePath
{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -88,74 +81,6 @@ See Note [Recompilation avoidance with bytecode objects]
-}
--- | The on-disk representation of a bytecode object for a specific module.
---
--- This is the representation which we serialise and write to disk.
--- The difference from 'ModuleByteCode' is that the contents of the object files
--- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
--- temporary files.
-data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module
- , odgbc_compiled_byte_code :: CompiledByteCode
- , odgbc_foreign :: [ByteString] -- ^ Contents of object files
- }
-
-type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents)
-
-instance Outputable a => Outputable (BytecodeLibX a) where
- ppr (BytecodeLib {..}) = vcat [
- (text "BytecodeLib" <+> ppr bytecodeLibUnitId),
- (text "Files" <+> ppr bytecodeLibFiles),
- (text "Foreign" <+> ppr bytecodeLibForeign) ]
-
-type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)
-
--- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
-data BytecodeLibX a = BytecodeLib {
- bytecodeLibUnitId :: UnitId,
- bytecodeLibFiles :: [CompiledByteCode],
- bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
-}
-
-data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String }
- | InterpreterStaticObjects { getStaticObjects :: [FilePath] }
-
-
-instance Outputable InterpreterLibrary where
- ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name
- ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths)
-
-
-data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString }
- | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] }
-
-instance Binary InterpreterLibraryContents where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> InterpreterLibrarySharedContents <$> get bh
- 1 -> InterpreterLibraryStaticContents <$> get bh
- _ -> panic "Binary InterpreterLibraryContents: invalid byte"
- put_ bh (InterpreterLibrarySharedContents contents) = do
- putByte bh 0
- put_ bh contents
- put_ bh (InterpreterLibraryStaticContents contents) = do
- putByte bh 1
- put_ bh contents
-
-instance Binary OnDiskBytecodeLib where
- get bh = do
- bytecodeLibUnitId <- get bh
- bytecodeLibFiles <- get bh
- bytecodeLibForeign <- get bh
- pure BytecodeLib {..}
-
- put_ bh BytecodeLib {..} = do
- put_ bh bytecodeLibUnitId
- put_ bh bytecodeLibFiles
- put_ bh bytecodeLibForeign
-
-
-
writeBytecodeLib :: BytecodeLib -> FilePath -> IO ()
writeBytecodeLib lib path = do
odbco <- encodeBytecodeLib lib
@@ -168,22 +93,10 @@ 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
-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
-
-- | Convert an 'OnDiskModuleByteCode' to an 'ModuleByteCode'.
-- 'OnDiskModuleByteCode' is the representation which we read from a file,
-- the 'ModuleByteCode' is the representation which is manipulated by program logic.
@@ -198,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
@@ -257,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.
@@ -269,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.
@@ -282,169 +197,12 @@ writeBinByteCode f cbc = do
putWithUserData QuietBinIFace NormalCompression bh odbco
writeBinMem bh f
-instance Binary CompiledByteCode where
- get bh = do
- bc_bcos <- get bh
- bc_itbls_len <- get bh
- bc_itbls <- replicateM bc_itbls_len $ do
- nm <- getViaBinName bh
- itbl <- get bh
- pure (nm, itbl)
- bc_strs_len <- get bh
- bc_strs <-
- replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
- bc_breaks <- get bh
- bc_spt_entries <- get bh
- return $
- CompiledByteCode
- { bc_bcos,
- bc_itbls,
- bc_strs,
- bc_breaks,
- bc_spt_entries
- }
-
- put_ bh CompiledByteCode {..} = do
- put_ bh bc_bcos
- put_ bh $ length bc_itbls
- for_ bc_itbls $ \(nm, itbl) -> do
- putViaBinName bh nm
- put_ bh itbl
- put_ bh $ length bc_strs
- for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str
- put_ bh bc_breaks
- put_ bh bc_spt_entries
-
-instance Binary UnlinkedBCO where
- get bh =
- UnlinkedBCO
- <$> getViaBinName bh
- <*> get bh
- <*> (Binary.decode <$> get bh)
- <*> (Binary.decode <$> get bh)
- <*> get bh
- <*> get bh
-
- put_ bh UnlinkedBCO {..} = do
- putViaBinName bh unlinkedBCOName
- put_ bh unlinkedBCOArity
- put_ bh $ Binary.encode unlinkedBCOInstrs
- put_ bh $ Binary.encode unlinkedBCOBitmap
- put_ bh unlinkedBCOLits
- put_ bh unlinkedBCOPtrs
+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
-instance Binary BCOPtr where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> BCOPtrName <$> getViaBinName bh
- 1 -> BCOPtrPrimOp <$> get bh
- 2 -> BCOPtrBCO <$> get bh
- 3 -> BCOPtrBreakArray <$> get bh
- _ -> panic "Binary BCOPtr: invalid byte"
-
- put_ bh ptr = case ptr of
- BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm
- BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
- BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
- BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
-
-instance Binary BCONPtr where
- get bh = do
- t <- getByte bh
- case t of
- 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
- 1 -> BCONPtrLbl <$> get bh
- 2 -> BCONPtrItbl <$> getViaBinName bh
- 3 -> BCONPtrAddr <$> getViaBinName bh
- 4 -> BCONPtrStr <$> get bh
- 5 -> BCONPtrFS <$> get bh
- 6 -> BCONPtrFFIInfo <$> get bh
- 7 -> BCONPtrCostCentre <$> get bh
- _ -> panic "Binary BCONPtr: invalid byte"
-
- put_ bh ptr = case ptr of
- BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
- BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
- BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm
- BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm
- BCONPtrStr str -> putByte bh 4 *> put_ bh str
- BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
- BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
- BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
-
-newtype BinName = BinName {unBinName :: Name}
-
-getViaBinName :: ReadBinHandle -> IO Name
-getViaBinName bh = case findUserDataReader Proxy bh of
- BinaryReader f -> unBinName <$> f bh
-
-putViaBinName :: WriteBinHandle -> Name -> IO ()
-putViaBinName bh nm = case findUserDataWriter Proxy bh of
- BinaryWriter f -> f bh $ BinName nm
-
-data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64
- , _bytecode_name_subst :: NameEnv Word64
- }
-
-addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
-addBinNameWriter bh' = do
- env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv)
- evaluate
- $ flip addWriterToUserData bh'
- $ BinaryWriter
- $ \bh (BinName nm) ->
- if
- | isExternalName nm -> do
- putByte bh 0
- put_ bh nm
- | otherwise -> do
- putByte bh 1
- key <- getBinNameKey env_ref nm
- -- Delimit the OccName from the deterministic counter to keep the
- -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
- put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
- where
- -- Find a deterministic key for local names. This
- getBinNameKey ref name = do
- atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) ->
- case lookupNameEnv subst name of
- Just idx -> (b, idx)
- Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
-
-addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
-addBinNameReader HscEnv {..} bh' = do
- env_ref <- newIORef emptyOccEnv
- pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
- t <- getByte bh
- case t of
- 0 -> do
- nm <- get bh
- pure $ BinName nm
- 1 -> do
- occ <- mkVarOccFS <$> get bh
- -- 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
- evaluate $ mkInternalName u occ noSrcSpan
- fmap BinName $ atomicModifyIORef' env_ref $ \env ->
- case lookupOccEnv env occ of
- Just nm -> (env, nm)
- _ -> nm' `seq` (extendOccEnv env occ nm', nm')
- _ -> panic "Binary BinName: invalid byte"
-
--- Note [Serializing Names in bytecode]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The bytecode related types contain various Names which we need to
--- serialize. Unfortunately, we can't directly use the Binary instance
--- of Name: it is only meant to be used for serializing external Names
--- in BinIface logic, but bytecode does contain internal Names.
---
--- We also need to maintain the invariant that: any pair of internal
--- Names with equal/different uniques must also be deserialized to
--- have the same equality. Therefore when we write the names to the interface, we
--- use an incrementing counter to give each local name it's own unique number. A substitution
--- is maintained to give each occurence of the Name the same unique key. When the interface
--- is read, a reverse mapping is used from these unique keys to a Name.
---
+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
=====================================
@@ -301,8 +301,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
{- **********************************************************************
%* *
@@ -866,7 +865,7 @@ hscRecompStatus
| otherwise -> do
-- Check the status of all the linkable types we might need.
-- 1. The in-memory linkable we had at hand.
- bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable)
+ bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable)
-- 2. The bytecode object file
bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary
-- 3. Bytecode from an interface's whole core bindings.
@@ -1013,7 +1012,7 @@ 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
+ bco <- ByteCode.readBinByteCode hsc_env obj_fn
return $ mkModuleByteCodeLinkable obj_date bco
return $ UpToDateItem linkable
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
@@ -1098,7 +1097,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
@@ -1106,8 +1105,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)
@@ -1148,14 +1148,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.
--
@@ -2217,7 +2217,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
{-
@@ -2232,20 +2232,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
@@ -2767,13 +2767,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?
@@ -2859,8 +2859,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 -}
@@ -2876,7 +2877,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
@@ -225,6 +230,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"
@@ -718,6 +724,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
@@ -739,6 +754,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.
@@ -760,14 +796,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,
@@ -1032,19 +1068,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
=====================================
@@ -228,7 +228,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
@@ -258,7 +258,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
@@ -645,7 +645,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)
@@ -659,19 +659,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
@@ -723,7 +718,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
@@ -823,7 +818,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
@@ -952,17 +947,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
{- **********************************************************************
@@ -1115,7 +1110,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,
@@ -1125,7 +1120,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
@@ -1133,7 +1128,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,11 +18,12 @@ 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, linkableModuleByteCodes )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Stack.Types (HasCallStack)
-- | Status of a module in incremental compilation
data HscRecompStatus
@@ -59,7 +60,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
@@ -86,8 +87,11 @@ safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable
justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
justBytecode = \case
Left lm ->
+ let
+ mbc = expectSingletonGbcLinkable lm
+ in
assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just mbc) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -98,8 +102,17 @@ justObjects lm =
bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
bytecodeAndObjects either_bc o = case either_bc of
Left bc ->
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ let
+ mbc = expectSingletonGbcLinkable bc
+ in
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ $ RecompLinkables (NormalLinkable (Just mbc)) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
+
+expectSingletonGbcLinkable :: HasCallStack => Linkable -> LinkableWith ModuleByteCode
+expectSingletonGbcLinkable lm = case linkableModuleByteCodes lm of
+ [] -> pprPanic "Expected 1 ModuleByteCode in Linkable" (ppr lm)
+ [mbc] -> mbc <$ lm
+ _ -> pprPanic "Expected 1 in Linkable" (ppr lm)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -210,10 +210,12 @@ Library
GHC.Builtin.Uniques
GHC.Builtin.Utils
GHC.ByteCode.Asm
+ GHC.ByteCode.Binary
GHC.ByteCode.Breakpoints
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/-/commit/31a3cbc3cf14831f506f1e52933e596…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31a3cbc3cf14831f506f1e52933e596…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
45fcde34 by Simon Peyton Jones at 2026-03-16T13:27:08+00:00
Improve knownCon
Eliminate simplInVar
Just a refactoring to simplify the code
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2265,19 +2265,6 @@ Some programs have a /lot/ of data constructors in the source program
valuable.
-}
-simplInVar :: SimplEnv -> InVar -> SimplM OutExpr
--- Look up an InVar in the environment
-simplInVar env var
- -- Why $! ? See Note [Bangs in the Simplifier]
- | isTyVar var = return $! Type $! (substTyVar env var)
- | isCoVar var = return $! Coercion $! (substCoVar env var)
- | otherwise
- = case substId env var of
- ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids
- in simplExpr env' e
- DoneId var1 -> return (Var var1)
- DoneEx e _ -> return e
-
simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplInId env var cont
| Just dc <- isDataConWorkId_maybe var
@@ -2644,7 +2631,7 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity
tryRules :: Bool -- True <=> args are already simplified
-> SimplEnv -> [CoreRule]
- -> OutId -> [CoreExpr]
+ -> OutId -> [OutExpr]
-> SimplM (Maybe (FullArgCount, CoreExpr))
tryRules args_are_simplified env rules fn args
@@ -3070,25 +3057,6 @@ may be a result of 'seq' so we *definitely* don't want to drop those.
I don't really know how to improve this situation.
-Note [FloatBinds from constructor wrappers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have FloatBinds coming from the constructor wrapper
-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
-we cannot float past them. We'd need to float the FloatBind
-together with the simplify floats, unfortunately the
-simplifier doesn't have case-floats. The simplest thing we can
-do is to wrap all the floats here. The next iteration of the
-simplifier will take care of all these cases and lets.
-
-Given data T = MkT !Bool, this allows us to simplify
-case $WMkT b of { MkT x -> f x }
-to
-case b of { b' -> f b' }.
-
-We could try and be more clever (like maybe wfloats only contain
-let binders, so we could float them). But the need for the
-extra complication is not clear.
-
Note [Do not duplicate constructor applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (#20125)
@@ -3133,7 +3101,7 @@ rebuildCase env scrut case_bndr alts cont
= do { tick (KnownBranch case_bndr)
; case findAlt (LitAlt lit) alts of
Nothing -> missingAlt env case_bndr alts cont
- Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }
+ Just (Alt _ bs rhs) -> simple_rhs env scrut bs rhs }
| Just (in_scope', wfloats, con, ty_args, other_args)
<- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
@@ -3141,58 +3109,26 @@ rebuildCase env scrut case_bndr alts cont
-- as well as when it's an explicit constructor application
, let env0 = setInScopeSet env in_scope'
= do { tick (KnownBranch case_bndr)
- ; let scaled_wfloats = map scale_float wfloats
- -- case_bndr_unf: see Note [Do not duplicate constructor applications]
+ ; let -- case_bndr_unf: see Note [Do not duplicate constructor applications]
case_bndr_rhs | exprIsTrivial scrut = scrut
| otherwise = con_app
con_app = Var (dataConWorkId con) `mkTyApps` ty_args
`mkApps` other_args
- ; case findAlt (DataAlt con) alts of
+ ; wrapDataConFloats env wfloats case_bndr cont $
+ case findAlt (DataAlt con) alts of
Nothing -> missingAlt env0 case_bndr alts cont
- Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs
- Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args
+ Just (Alt DEFAULT bs rhs) -> simple_rhs env0 case_bndr_rhs bs rhs
+ Just (Alt _ bs rhs) -> knownCon env0 scrut con
other_args case_bndr bs rhs cont
}
where
- simple_rhs env wfloats case_bndr_rhs bs rhs =
+ simple_rhs env case_bndr_rhs bs rhs =
assert (null bs) $
do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs
-- scrut is a constructor application,
-- hence satisfies let-can-float invariant
; (floats2, expr') <- simplExprF env' rhs cont
- ; case wfloats of
- [] -> return (floats1 `addFloats` floats2, expr')
- _ -> return
- -- See Note [FloatBinds from constructor wrappers]
- ( emptyFloats env,
- GHC.Core.Make.wrapFloats wfloats $
- wrapFloats (floats1 `addFloats` floats2) expr' )}
-
- -- This scales case floats by the multiplicity of the continuation hole (see
- -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because
- -- they are aliases anyway.
- scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =
- let
- scale_id id = scaleVarBy holeScaling id
- in
- GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)
- scale_float f = f
-
- holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr
- -- We are in the following situation
- -- case[p] case[q] u of { D x -> C v } of { C x -> w }
- -- And we are producing case[??] u of { D x -> w[x\v]}
- --
- -- What should the multiplicity `??` be? In order to preserve the usage of
- -- variables in `u`, it needs to be `pq`.
- --
- -- As an illustration, consider the following
- -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }
- -- Where C :: A %1 -> T is linear
- -- If we were to produce a case[1], like the inner case, we would get
- -- case[1] of { C x -> (x, x) }
- -- Which is ill-typed with respect to linearity. So it needs to be a
- -- case[Many].
+ ; return (floats1 `addFloats` floats2, expr') }
--------------------------------------------------
-- 2. Eliminate the case if scrutinee is evaluated
@@ -3740,29 +3676,81 @@ and then
f (h v)
All this should happen in one sweep.
+
+Note [FloatBinds from constructor wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have FloatBinds coming from the constructor wrapper
+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
+we cannot float past them. We'd need to float the FloatBind
+together with the simplify floats, unfortunately the
+simplifier doesn't have case-floats. The simplest thing we can
+do is to wrap all the floats here. The next iteration of the
+simplifier will take care of all these cases and lets.
+
+Given data T = MkT !Bool, this allows us to simplify
+case $WMkT b of { MkT x -> f x }
+to
+case b of { b' -> f b' }.
+
+We could try and be more clever (like maybe wfloats only contain
+let binders, so we could float them). But the need for the
+extra complication is not clear.
-}
+wrapDataConFloats :: SimplEnv -> [FloatBind] -> InId -> SimplCont
+ -> SimplM (SimplFloats, OutExpr)
+ -> SimplM (SimplFloats, OutExpr)
+-- See Note [FloatBinds from constructor wrappers]
+wrapDataConFloats env wfloats case_bndr cont thing_inside
+ | null wfloats
+ = thing_inside
+ | otherwise
+ = do { (floats, expr) <- thing_inside
+ ; return ( emptyFloats env
+ , GHC.Core.Make.wrapFloats (map scale_float wfloats) $
+ wrapFloats floats expr ) }
+ where
+ -- scale_float scales case-floats by the multiplicity of the continuation hole
+ -- (see Note [Scaling in case-of-case]).
+ -- Let floats are _not_ scaled, because they are aliases anyway.
+ scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars)
+ = GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)
+ scale_float flt(a)(GHC.Core.Make.FloatLet {})
+ = flt
+
+ scale_id id = scaleVarBy holeScaling id
+
+ holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr
+ -- We are in the following situation
+ -- case[p] case[q] u of { D x -> C v } of { C x -> w }
+ -- And we are producing case[??] u of { D x -> w[x\v]}
+ --
+ -- What should the multiplicity `??` be? In order to preserve the usage of
+ -- variables in `u`, it needs to be `pq`.
+ --
+ -- As an illustration, consider the following
+ -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }
+ -- Where C :: A %1 -> T is linear
+ -- If we were to produce a case[1], like the inner case, we would get
+ -- case[1] of { C x -> (x, x) }
+ -- Which is ill-typed with respect to linearity. So it needs to be a
+ -- case[Many].
+
+
knownCon :: SimplEnv
- -> OutExpr -- The scrutinee
- -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
- -> InId -> [InBndr] -> InExpr -- The alternative
+ -> OutExpr -- The scrutinee
+ -> DataCon -> [OutExpr] -- The scrutinee (in pieces)
+ -> InId -> [InBndr] -> InExpr -- The alternative
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
-knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
- = do { (floats1, env1) <- bind_args env bs dc_args
+knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont
+ = do { (floats1, env1) <- bind_args env alt_bndrs dc_args
; (floats2, env2) <- bind_case_bndr env1
; (floats3, expr') <- simplExprF env2 rhs cont
- ; case dc_floats of
- [] ->
- return (floats1 `addFloats` floats2 `addFloats` floats3, expr')
- _ ->
- return ( emptyFloats env
- -- See Note [FloatBinds from constructor wrappers]
- , GHC.Core.Make.wrapFloats dc_floats $
- wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }
+ ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
where
- zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
+ zap_occ = zapBndrOccInfo (isDeadBinder case_bndr) -- case_bndr is an InId
-- Ugh!
bind_args env' [] _ = return (emptyFloats env', env')
@@ -3787,28 +3775,32 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
; return (floats1 `addFloats` floats2, env3) }
bind_args _ _ _ =
- pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
+ pprPanic "bind_args" $ ppr dc $$ ppr alt_bndrs $$ ppr dc_args $$
text "scrut:" <+> ppr scrut
- -- It's useful to bind bndr to scrut, rather than to a fresh
+ -- It's useful to bind case_bndr to scrut, rather than to a fresh
-- binding x = Con arg1 .. argn
-- because very often the scrut is a variable, so we avoid
-- creating, and then subsequently eliminating, a let-binding
-- BUT, if scrut is a not a variable, we must be careful
-- about duplicating the arg redexes; in that case, make
-- a new con-app from the args
+ con_app :: InExpr
+ con_app = mkConApp2 dc (tyConAppArgs (idType case_bndr)) alt_bndrs
+
bind_case_bndr env
- | isDeadBinder bndr = return (emptyFloats env, env)
- | exprIsTrivial scrut = return (emptyFloats env
- , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))
- -- See Note [Do not duplicate constructor applications]
- | otherwise = do { dc_args <- mapM (simplInVar env) bs
- -- dc_ty_args are already OutTypes,
- -- but bs are InBndrs
- ; let con_app = Var (dataConWorkId dc)
- `mkTyApps` dc_ty_args
- `mkApps` dc_args
- ; simplAuxBind "case-bndr" env bndr con_app }
+ | exprIsTrivial scrut
+ = -- See Note [Do not duplicate constructor applications]
+ return ( emptyFloats env
+ , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint))
+
+ | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app env
+ = return (emptyFloats env', env')
+
+ | otherwise
+ = do { (env1, case_bndr1) <- simplNonRecBndr env case_bndr
+ ; simplLazyBind NotTopLevel NonRecursive
+ (case_bndr,env) (case_bndr1,env1) (con_app,env) }
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45fcde34e41e178082d41705ff7971b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45fcde34e41e178082d41705ff7971b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0