- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: EPA: Keep binds and sigs together in HsValBindsLR
by Marge Bot (＠marge-bot) 14 Jul '26

14 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cd00cfa6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 121fb5cb by Andreas Klebinger at 2026-07-13T19:17:55-04:00 Bump nofib submodule to account for MonoLocalBinds. New versions of GHC enable MonoLocalBinds by default. This breaks some of the benchmarks. I've fixed this and this bump pulls in that fix. - - - - - 26 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - nofib - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -78,7 +78,7 @@ type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen -- --------------------------------------------------------------------- -type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL @@ -154,6 +154,10 @@ data AnnPSB instance NoAnn AnnPSB where noAnn = AnnPSB noAnn noAnn noAnn noAnn +instance HasLoc (ValBind (GhcPass p) (GhcPass p)) where + getHasLoc (VbBind b) = getHasLoc b + getHasLoc (VbSig s) = getHasLoc s + -- --------------------------------------------------------------------- -- | Typechecked, generalised bindings, used in the output to the type checker. @@ -442,8 +446,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr) instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where - ppr (ValBinds _ binds sigs) - = pprDeclList (pprLHsBindsForUser binds sigs) + ppr (ValBinds _ binds) + = pprDeclList (pprLHsBindsForUser' binds) ppr (XValBindsLR (HsVBG bs sigs)) = getPprDebug $ \case @@ -487,6 +491,21 @@ pprLHsBindsForUser binds sigs sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls +pprLHsBindsForUser' :: (OutputableBndrId idL, OutputableBndrId idR) + => [ValBind (GhcPass idL) (GhcPass idR)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser' binds + = map ppr_bind binds + where + ppr_bind (VbBind b) = ppr b + ppr_bind (VbSig s) = ppr s + + pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations -- One could choose { d1; d2; ... }, using 'sep' @@ -507,11 +526,11 @@ eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBinds _ binds) = null binds isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds NoAnnSortKey [] [] +emptyValBindsIn = ValBinds noExtField [] emptyValBindsRn :: HsValBindsLR GhcRn GhcRn emptyValBindsRn = XValBindsLR (HsVBG [] []) @@ -532,8 +551,8 @@ hsValBindGroupsBinds binds ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBinds _ ds1) (ValBinds _ ds2) + = ValBinds noExtField (ds1 ++ ds2) plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2)) = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2)) plusHsValBinds _ _ ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -73,6 +73,11 @@ deriving instance Data (HsValBindsLR GhcPs GhcRn) deriving instance Data (HsValBindsLR GhcRn GhcRn) deriving instance Data (HsValBindsLR GhcTc GhcTc) +deriving instance Data (ValBind GhcPs GhcPs) +deriving instance Data (ValBind GhcPs GhcRn) +deriving instance Data (ValBind GhcRn GhcRn) +deriving instance Data (ValBind GhcTc GhcTc) + -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) deriving instance Data (HsValBindGroups 'Parsed) deriving instance Data (HsValBindGroups 'Renamed) ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -84,8 +84,8 @@ module GHC.Hs.Utils( -- * Collecting binders isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind, - collectLocalBinders, collectHsValBinders, collectHsBindListBinders, - collectHsIdBinders, + collectLocalBinders, collectHsValBinders, collectHsValBinders', collectHsBindListBinders, + collectHsIdBinders, collectHsIdBinders', collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, @@ -885,8 +885,11 @@ spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) = get_bind_spans bs [] -spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = get_bind_spans bs sigs +spanHsLocaLBinds (HsValBinds _ (ValBinds _ binds)) + = get_bind_spans bs ss + where + bs :: [LHsBindLR (GhcPass p) (GhcPass p)] + (bs,ss) = val_binds_and_sigs binds spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss))) = get_bind_spans (hsValBindGroupsBinds @p bs) ss @@ -1085,12 +1088,25 @@ collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL)) -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders flag = collect_hs_val_binders True flag +collectHsIdBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively +collectHsIdBinders' flag = collect_hs_val_binders' True flag + collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collectHsValBinders flag = collect_hs_val_binders False flag +collectHsValBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collectHsValBinders' flag = collect_hs_val_binders' False flag + collectHsBindBinders :: CollectPass p => CollectFlag p -> HsBindLR p idR @@ -1117,9 +1133,17 @@ collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case - ValBinds _ binds _ -> collect_binds ps flag binds [] + ValBinds _ binds -> collect_binds ps flag (val_binds binds) [] XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) [] +collect_hs_val_binders' :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL)) + => Bool + -> CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collect_hs_val_binders' ps flag binds = collect_binds ps flag binds [] + + collect_binds :: forall p idR. CollectPass p => Bool -> CollectFlag p @@ -1528,7 +1552,7 @@ hsForeignDeclsBinders foreign_decls hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBinds _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (HsVBG grps _)) = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps @@ -1814,8 +1838,8 @@ hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (HsVBG grps _)) = lhsBindsImplicits (hsValBindGroupsBinds grps) -hsValBindsImplicits (ValBinds _ binds _) - = lhsBindsImplicits binds +hsValBindsImplicits (ValBinds _ binds) + = lhsBindsImplicits (val_binds binds) lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] lhsBindsImplicits = concatMap (lhs_bind . unLoc) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -338,8 +338,8 @@ hsScopedTvBinders binds = concatMap get_scoped_tvs sigs where sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (HsVBG _ sigs) -> sigs + ValBinds _ bs -> val_sigs bs + XValBindsLR (HsVBG _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] get_scoped_tvs (L _ signature) @@ -2004,7 +2004,7 @@ rep_val_binds (XValBindsLR (HsVBG binds sigs)) = do { core1 <- rep_binds (concatMap snd binds) ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) +rep_val_binds (ValBinds _ _) = panic "rep_val_binds: ValBinds" rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1438,7 +1438,7 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where collectFldBinds HsIPBinds{} = emptyVarEnv collectFldBinds EmptyLocalBinds{} = emptyVarEnv instance CollectFldBinders (HsValBinds GhcTc) where - collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (ValBinds _ bnds) = collectFldBinds (val_binds bnds) collectFldBinds (XValBindsLR (HsVBG grps _)) = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps) instance CollectFldBinders (HsBind GhcTc) where ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1462,13 +1462,11 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where ] scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope -scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = foldr combineScopes NoScope (bsScope ++ sigsScope) +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs)) + = foldr combineScopes NoScope bsScope where bsScope :: [Scope] - bsScope = map (mkScope . getLoc) bs - sigsScope :: [Scope] - sigsScope = map (mkScope . getLocA) sigs + bsScope = map (mkScope . getHasLoc) bs scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs))) = foldr combineScopes NoScope (bsScope ++ sigsScope) where @@ -1491,7 +1489,9 @@ instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> + ValBinds _ binds_and_sigs -> + let (binds, sigs) = val_binds_and_sigs binds_and_sigs + in [ toHie $ fmap (BC RegularBind sc) binds , toHie $ fmap (SC (SI BindSig Nothing)) sigs ] ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -41,7 +41,7 @@ module GHC.Parser.Annotation ( NameAnn(..), NameAdornment(..), NoEpAnns(..), - AnnSortKey(..), DeclTag(..), BindTag(..), + AnnSortKey(..), DeclTag(..), -- ** Trailing annotations in lists TrailingAnn(..), ta_location, @@ -652,13 +652,6 @@ data AnnSortKey tag | AnnSortKey [tag] deriving (Data, Eq) --- | Used to track of interleaving of binds and signatures for ValBind -data BindTag - -- See Note [AnnSortKey] below - = BindTag - | SigDTag - deriving (Eq,Data,Ord,Show) - -- | Used to track interleaving of class methods, class signatures, -- associated types and associate type defaults in `ClassDecl` and -- `ClsInstDecl`. @@ -1179,9 +1172,6 @@ instance Outputable EpAnnComments where instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where getName (L l a) = getName (L (locA l) a) -instance Outputable BindTag where - ppr tag = text $ show tag - instance Outputable DeclTag where ppr tag = text $ show tag ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Parser.PostProcess ( addModifiersToDecl, cvBindGroup, + cvBindsAndSigsOnly, wrapValBind, cvBindsAndSigs, cvTopDecls, placeHolderPunRhs, @@ -521,10 +522,28 @@ cvTopDecls decls = getMonoBindAll (fromOL decls) -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts - , dfam_insts, _) <- cvBindsAndSigs binding - ; massert (null fam_ds && null tfam_insts && null dfam_insts) - ; return $ ValBinds NoAnnSortKey mbs sigs } + = do { binds <- cvBindsAndSigsOnly binding + ; return $ ValBinds noExtField binds } + +cvBindsAndSigsOnly :: OrdList (LHsDecl GhcPs) + -> P [ValBind GhcPs GhcPs] +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigsOnly fb = do + fb' <- drop_bad_decls (fromOL fb) + return (fmap wrapValBind (getMonoBindAll fb')) + where + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +wrapValBind :: LHsDecl (GhcPass p) -> ValBind (GhcPass p) (GhcPass p) +wrapValBind (L l (ValD _ b)) = VbBind (L l b) +wrapValBind (L l (SigD _ s)) = VbSig (L l s) +wrapValBind _ = panic "wrapValBind: got unexpected decl" cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -195,21 +195,18 @@ it expects the global environment to contain bindings for the binders -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -- Ensure that a hs-boot file has no top-level bindings. rnTopBindsLHSBoot :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHSBoot fix_env binds - = do { topBinds <- rnTopBindsLHS fix_env binds - ; case topBinds of - ValBinds x mbinds sigs -> - do { rejectBootDecls HsBoot BootBindsPs mbinds - ; pure (ValBinds x [] sigs) } - _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } + = do { (mbinds, sigs) <- rnTopBindsLHS fix_env binds + ; rejectBootDecls HsBoot BootBindsPs mbinds + ; pure ([], sigs) } rejectBootDecls :: HsBootOrSig -> (NonEmpty (LocatedA decl) -> BadBootDecls) @@ -225,8 +222,8 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ _ sigs) - = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs +rnTopBindsBoot bound_names (ValBinds _ val_binds) + = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) (val_sigs val_binds) ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -278,9 +275,9 @@ rnIPBind (IPBind _ n expr) = do -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM ([Name], HsValBindsLR GhcRn GhcPs) + -> RnM ([Name], ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])) rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + = do { (binds',sigs) <- rnValBindsLHS (localRecNameMaker fix_env) binds -- Check for duplicates and shadowing -- Must do this *after* renaming the patterns @@ -300,26 +297,27 @@ rnLocalValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; let bound_names = collectHsValBinders CollNoDictBinders binds' + ; let bound_names = collectHsValBinders' CollNoDictBinders binds' -- There should be only Ids, but if there are any bogus -- pattern synonyms, we'll collect them anyway, so that -- we don't generate subsequent out-of-scope messages ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names - ; return (bound_names, binds') } + ; return (bound_names, (binds', sigs)) } -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHS :: NameMaker -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) +rnValBindsLHS topP (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds + ; return (mbinds', sigs) } where - bndrs = collectHsBindsBinders CollNoDictBinders mbinds + bndrs = collectHsBindsBinders CollNoDictBinders (val_binds vbinds) doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -332,8 +330,9 @@ rnValBindsRHS :: HsSigCtxt -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs +rnValBindsRHS ctxt (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; (sigs', sig_fvs) <- renameSigs ctxt sigs -- Update the TcGblEnv with renamed COMPLETE pragmas from the current -- module, for pattern irrefutability checking in do notation. @@ -383,20 +382,22 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeNames -> RnM (result, FreeNames)) -> RnM (result, FreeNames) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [ L loc sig +rnLocalValBindsAndThen binds@(ValBinds _ vbinds) thing_inside + = do { let sigs = val_sigs vbinds + -- (A) Create the local fixity environment + ; new_fixities <- makeMiniFixityEnv [ L loc sig | L loc (FixSig _ sig) <- sigs] -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + ; (bound_names, (binds',sigs')) <- rnLocalValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + let new_lhs :: HsValBindsLR GhcRn GhcPs = ValBinds noExtField (map VbBind binds' ++ map VbSig sigs') + ; (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' (allUses dus) -- Report unused bindings based on the (accurate) ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -1546,10 +1546,10 @@ rnRecStmtsAndThen ctxt rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ bs)))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc - _ -> acc) acc sigs + _ -> acc) acc (val_sigs bs) _ -> acc) [] l -- left-hand sides @@ -1578,8 +1578,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noAnn (HsValBinds x binds')), + = do (_bound_names, (bs',sigs')) <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noAnn (HsValBinds x (makeRnValBinds noExtField bs' sigs'))), -- Warning: this is bogus; see function invariant emptyFNs )] ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -32,7 +32,8 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNames, bindLocalNamesFV , warnUnusedTypePatterns , noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars ) + , addNoNestedForallsContextsErr, checkInferredVars + , makeRnValBinds) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names @@ -148,12 +149,12 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- We need to throw an error on such value bindings when in a boot file. is_boot <- tcIsHsBootOrSig ; - new_lhs <- if is_boot + (binds', sigs') <- if is_boot then rnTopBindsLHSBoot local_fix_env val_decls else rnTopBindsLHS local_fix_env val_decls ; -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + let { id_bndrs = collectHsIdBinders' CollNoDictBinders binds' } ; -- Excludes pattern-synonym binders -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; @@ -178,6 +179,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn "Start rnmono" empty ; let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + let { new_lhs = makeRnValBinds noExtField binds' sigs' } ; (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot -- For an hs-boot, use tc_bndrs (which collects how we're renamed -- signatures), since val_bndr_set is empty (there are no x = ... @@ -2723,7 +2725,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { where new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps (ValBinds _ binds) = foldrM new_ps' [] (val_binds binds) new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2921,9 +2923,9 @@ add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) = tycls { group_kisigs = d : kisigs } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs +add_bind b (ValBinds x bs) = ValBinds x (bs ++ [VbBind b]) add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig s (ValBinds x bs) = ValBinds x (VbSig s:bs) add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -819,11 +819,11 @@ getLocalNonValBinders fixity_env ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = case binds of - ValBinds _ _val_binds val_sigs -> + ValBinds _ val_binds -> -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ _ ns _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig _ _ ns _) <- (val_sigs val_binds), n <- ns] _ -> panic "Non-ValBinds in hs-boot group" | otherwise = for_hs_bndrs ; val_gres <- mapM new_simple val_bndrs ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -35,7 +35,9 @@ module GHC.Rename.Utils ( addNameClashErrRn, mkNameClashErr, checkInferredVars, - noNestedForallsContextsErr, addNoNestedForallsContextsErr + noNestedForallsContextsErr, addNoNestedForallsContextsErr, + + makeRnValBinds ) where @@ -868,3 +870,9 @@ mkExpandedTc -> LHsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc' mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e)) + +makeRnValBinds :: XValBinds idL idR + -> [XRec idL (HsBindLR idL idR)] + -> [XRec idR (Sig idR)] + -> HsValBindsLR idL idR +makeRnValBinds x binds sigs = ValBinds x (map VbBind binds ++ map VbSig sigs) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1261,8 +1261,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do loc' = locA loc expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc' let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $ - ValBinds NoAnnSortKey - [mkHsVarBind loc' (getRdrName expr_name) expr] [] + ValBinds noExtField + [VbBind $ mkHsVarBind loc' (getRdrName expr_name) expr] pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt let (hvals_io, fix_env) = case pstmt of ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -296,13 +296,13 @@ renameDeriv inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; let (aux_binds, aux_sigs) = unzipBag bagBinds - aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs) + aux_val_binds = ValBinds noExtField (map VbBind (bagToList aux_binds) ++ map VbSig (bagToList aux_sigs)) -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename -- auxiliary bindings as if they were defined locally. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. - ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds + ; (bndrs, (binds', sigs')) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds ; bindLocalNames bndrs $ - do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) (makeRnValBinds noExtField binds' sigs') ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos ; return (listToBag rn_inst_infos, rn_aux, dus_aux `plusDU` usesOnly (plusFNs fvs_insts)) } } ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1052,17 +1052,21 @@ cvtLocalDecs declDescr ds ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds - let (binds, prob_sigs) = partitionWith is_bind ds' - let (sigs, bads) = partitionWith is_sig prob_sigs + let (binds, bads) = partitionWith is_valbind ds' for_ (nonEmpty bads) $ \ bad_decls -> failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) - return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs)) + return (HsValBinds noAnn (ValBinds noExtField binds)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> failWith ImplicitParamsWithOtherBinds +is_valbind :: LHsDecl (GhcPass p) -> Either (ValBind (GhcPass p) (GhcPass p)) (LHsDecl (GhcPass p)) +is_valbind (L l (Hs.ValD _ b)) = Left (VbBind (L l b)) +is_valbind (L l (Hs.SigD _ s)) = Left (VbSig (L l s)) +is_valbind d = Right d + cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -31,6 +31,7 @@ import Language.Haskell.Syntax.ImpExp (NamespaceSpecifier) import Data.Bool import Data.Maybe +import Data.List {- ************************************************************************ @@ -96,7 +97,7 @@ data HsValBindsLR idL idR -- Recursive by default ValBinds (XValBinds idL idR) - (LHsBindsLR idL idR) [LSig idR] + [ValBind idL idR] -- | Value Bindings Out -- @@ -105,6 +106,10 @@ data HsValBindsLR idL idR | XValBindsLR !(XXValBindsLR idL idR) +data ValBind idL idR + = VbBind (LHsBindLR idL idR) + | VbSig (LSig idR) + -- --------------------------------------------------------------------- -- | Located Haskell Binding @@ -243,6 +248,26 @@ data PatSynBind idL idR } | XPatSynBind !(XXPatSynBind idL idR) + +val_binds :: [ValBind idL idR] -> [LHsBindLR idL idR] +val_binds binds = concatMap get_bind binds + where + get_bind (VbBind b) = [b] + get_bind (VbSig _) = [] + +val_sigs :: [ValBind idL idR] -> [LSig idR] +val_sigs binds = concatMap get_sig binds + where + get_sig (VbBind _) = [] + get_sig (VbSig s) = [s] + +val_binds_and_sigs :: [ValBind idL idR] -> ([LHsBindLR idL idR], [LSig idR]) +val_binds_and_sigs binds = go binds [] [] + where + go [] bs ss = (reverse bs, reverse ss) + go ((VbBind b):ds) bs ss = go ds (b:bs) ss + go ((VbSig s):ds) bs ss = go ds bs (s:ss) + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -205,6 +205,7 @@ type family XXHsLocalBindsLR x x' -- HsValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' +type family XXValBinds x x' -- HsBindLR type families type family XFunBind x x' ===================================== ghc/GHCi/UI.hs ===================================== @@ -1633,7 +1633,7 @@ runStmt input step = do let la = L (noAnnSrcSpan loc) la' = L (noAnnSrcSpan loc) - in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey [la' bind] []))) + in la (LetStmt noAnn (HsValBinds noAnn (ValBinds noExtField [VbBind $ la' bind]))) setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do ===================================== nofib ===================================== @@ -1 +1 @@ -Subproject commit ae985b599e958414b327e4f220d99b7248601d55 +Subproject commit d4750745a96ee293612cef0fedd8ed2c9ae8d1a0 ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1915,220 +1915,221 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:22 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:23 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:22 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:23 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: y})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:20-21 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: y})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:20-21 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:20 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:21 }) - [] + (EpaSpan { DumpSemis.hs:34:20-21 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:20 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:21 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 2) - (False) - (2)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))])))) - ,(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:27 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:28 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:29 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:30 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 2) + (False) + (2)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))]))))) + ,(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:27 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:28 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:29 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:30 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: z})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:25-26 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: z})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:25-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:25 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:26 }) - [] + (EpaSpan { DumpSemis.hs:34:25-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:25 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:26 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 3) - (False) - (3)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 3) + (False) + (3)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])) (L (EpAnn (EpaSpan { DumpSemis.hs:34:35 }) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -166,8 +166,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -295,142 +294,142 @@ "-- comment2") { Test20297.hs:10:3-7 }))])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.hs:11:17-26 }) - (NoEpAnns) + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.hs:11:17-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.hs:11:17 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.hs:11:19-26 }) - [] + (EpaSpan { Test20297.hs:11:17-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.hs:11:17 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.hs:11:19-26 }) [] - (EpaSpan { Test20297.hs:11:19-20 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.hs:11:19-20 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) @@ -595,8 +594,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -712,141 +710,141 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (NoEpAnns) + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.ppr.hs:9:15 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.ppr.hs:9:17-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:15-24 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.ppr.hs:9:15 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:17-24 }) [] - (EpaSpan { Test20297.ppr.hs:9:17-18 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.ppr.hs:9:17-18 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2523,15 +2523,18 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (ValBinds sortKey binds sigs) = do - decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) - let - binds' = concatMap decl2Bind decls - sigs' = concatMap decl2Sig decls - sortKey' = captureOrderBinds decls - return (ValBinds sortKey' binds' sigs') + exact (ValBinds sortKey bs) = do + bs' <- mapM markAnnotated bs + return (ValBinds sortKey bs') exact (XValBindsLR _) = panic "XValBindsLR" +instance ExactPrint (ValBind GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (VbBind b) = VbBind <$> markAnnotated b + exact (VbSig s) = VbSig <$> markAnnotated s + undynamic :: Typeable a => [Dynamic] -> [a] undynamic ds = mapMaybe fromDynamic ds ===================================== utils/check-exact/Main.hs ===================================== @@ -11,9 +11,11 @@ import Data.Data import Data.List (intercalate) +-- import Language.Haskell.Syntax.Binds import GHC hiding (moduleName) import GHC.Driver.Ppr import GHC.Hs.Dump +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Utils.Error @@ -447,15 +449,15 @@ changeLetIn1 _libdir parsed replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (tkLet, _) localDecls expr) = - let (HsValBinds x (ValBinds xv decls sigs)) = localDecls - [l2,_l1] = map wrapDecl decls - decls' = concatMap decl2Bind [l2] + let (HsValBinds x (ValBinds xv bs)) = localDecls + [l2,_l1] = bs + decls' = [l2] (L _ e) = expr a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments expr' = L a e tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) []) in (HsLet (tkLet, tkIn') - (HsValBinds x (ValBinds xv decls' sigs)) expr') + (HsValBinds x (ValBinds xv decls')) expr') replace x = x @@ -508,27 +510,24 @@ changeAddDecl3 libdir top = do -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls libdir (L l p) = do - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 0) let (p',_,_w) = runTransform doAddLocal doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) - replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do - let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs - let decls = s:d:oldDecls + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ bs))))) = do + let (oldDecls) = map unWrapValBind bs + -- let decls = s:d:oldDecls let oldDecls' = captureLineSpacing oldDecls - let oldBinds = concatMap decl2Bind oldDecls' - (os:oldSigs) = concatMap decl2Sig oldDecls' - os' = setEntryDP os (DifferentLine 2 0) - let sortKey = captureOrderBinds decls + let (VbSig o:oldBinds) = map wrapValBind oldDecls' + o' = setEntryDP o (DifferentLine 2 0) let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs) let binds' = (HsValBinds van' - (ValBinds sortKey (decl':oldBinds) - (sig':os':oldSigs))) + (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) `debug` ("oldDecls=" ++ showAst oldDecls) replaceLocalBinds x = return x @@ -540,8 +539,8 @@ changeLocalDecls libdir (L l p) = do -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer changeLocalDecls2 libdir (L l p) = do - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 2) let (p',_,_w) = runTransform doAddLocal @@ -557,10 +556,8 @@ changeLocalDecls2 libdir (L l p) = do (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) []) emptyComments - let decls = [s,d] - let sortKey = captureOrderBinds decls - let binds = (HsValBinds an (ValBinds sortKey [decl'] - [sig'])) + let decls = [VbSig sig', VbBind decl'] + let binds = (HsValBinds an (ValBinds noExtField decls)) return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x return (L l p') ===================================== utils/check-exact/Transform.hs ===================================== @@ -68,7 +68,6 @@ module Transform , addModuleCommentOrigDeltas -- ** Managing lists, pure functions - , captureOrderBinds , captureLineSpacing , captureMatchLineSpacing , captureTypeSigSpacing @@ -92,6 +91,7 @@ import Control.Monad.RWS import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString import GHC.Types.SrcLoc @@ -507,7 +507,7 @@ pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) vb = case replaceDeclsValbinds w lb (reverse decls') of (HsValBinds _ vb') -> vb' - _ -> ValBinds NoAnnSortKey [] [] + _ -> ValBinds noExtField [] balanceCommentsListA :: [LocatedA a] -> [LocatedA a] @@ -1084,18 +1084,11 @@ replaceDeclsValbinds w b@(HsValBinds a _) new = let oldSpan = spanHsLocaLBinds b an = oldWhereAnnotation a w (realSrcSpan oldSpan) - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" replaceDeclsValbinds w (EmptyLocalBinds _) new - = let - an = newWhereAnnotation w - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + = let an = newWhereAnnotation w + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) ===================================== utils/check-exact/Utils.hs ===================================== @@ -65,15 +65,6 @@ warn c _ = c -- --------------------------------------------------------------------- -captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag -captureOrderBinds ls = AnnSortKey $ map go ls - where - go (L _ (ValD _ _)) = BindTag - go (L _ (SigD _ _)) = SigDTag - go d = error $ "captureOrderBinds:" ++ showGhc d - --- --------------------------------------------------------------------- - notDocDecl :: LHsDecl GhcPs -> Bool notDocDecl (L _ DocD{}) = False notDocDecl _ = True @@ -655,45 +646,27 @@ partitionWithSortKey = go -- --------------------------------------------------------------------- -orderedDeclsBinds - :: AnnSortKey BindTag - -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] - -> [LHsDecl GhcPs] -orderedDeclsBinds sortKey binds sigs = - case sortKey of - NoAnnSortKey -> - sortBy (\a b -> compare (realSrcSpan $ getLocA a) - (realSrcSpan $ getLocA b)) (binds ++ sigs) - AnnSortKey keys -> - let - go [] _ _ = [] - go (BindTag:ks) (b:bs) ss = b : go ks bs ss - go (SigDTag:ks) bs (s:ss) = s : go ks bs ss - go (_:ks) bs ss = go ks bs ss - in - go keys binds sigs - hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs] hsDeclsLocalBinds lb = case lb of - HsValBinds _ (ValBinds sortKey bs sigs) -> - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds + HsValBinds _ (ValBinds _ bs) -> map unWrapValBind bs HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" HsIPBinds {} -> [] EmptyLocalBinds {} -> [] hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs] -hsDeclsValBinds (ValBinds sortKey bs sigs) = - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds +hsDeclsValBinds (ValBinds _ bs) = map unWrapValBind bs hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds" +unWrapValBind :: ValBind (GhcPass p) (GhcPass p) -> LHsDecl (GhcPass p) +unWrapValBind (VbBind (L l b)) = L l (ValD noExtField b) +unWrapValBind (VbSig (L l s)) = L l (SigD noExtField s) + +sig2Decl :: LSig (GhcPass p) -> LHsDecl (GhcPass p) +sig2Decl (L l s) = L l (SigD noExtField s) + +bind2Decl :: LHsBind (GhcPass p) -> LHsDecl (GhcPass p) +bind2Decl (L l b) = L l (ValD noExtField b) + -- --------------------------------------------------------------------- -- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8ce083b3edfc89826499ad0d3269b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8ce083b3edfc89826499ad0d3269b0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] chore: update user guide to reflect changed library versions
by Magnus (＠MangoIV) 14 Jul '26

14 Jul '26

Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: abf7c3be by mangoiv at 2026-07-13T20:28:18+02:00 chore: update user guide to reflect changed library versions - - - - - 1 changed file: - docs/users_guide/9.12.5-notes.rst Changes: ===================================== docs/users_guide/9.12.5-notes.rst ===================================== @@ -70,8 +70,8 @@ Bytecode Compiler Packaging and Build System ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- bumped ``process`` submodule to 1.6.29.0 -- bumped ``semaphore-compat`` submodule to 2.0.0 +- bumped ``process`` submodule to 1.6.30.0 +- bumped ``semaphore-compat`` submodule to 2.0.1 - accept ``happy`` version 2.2 - hadrian: don't include package hash in haddock library - configure: fix check for ``--target`` support in stage0 ``CC`` (:ghc-ticket:`26999`) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/abf7c3be17628108e5d70108a7089cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/abf7c3be17628108e5d70108a7089cd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] 2 commits: hadrian: update bootstrap plans
by Magnus (＠MangoIV) 14 Jul '26

14 Jul '26

Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: 95e85184 by mangoiv at 2026-07-13T20:24:32+02:00 hadrian: update bootstrap plans - - - - - 6751cbff by mangoiv at 2026-07-13T20:27:59+02:00 chore: update user guide to reflect changed library versions - - - - - 10 changed files: - docs/users_guide/9.12.5-notes.rst - hadrian/bootstrap/plan-9_10_1.json - hadrian/bootstrap/plan-9_6_1.json - hadrian/bootstrap/plan-9_6_2.json - hadrian/bootstrap/plan-9_6_3.json - hadrian/bootstrap/plan-9_6_4.json - hadrian/bootstrap/plan-9_6_5.json - hadrian/bootstrap/plan-9_6_6.json - hadrian/bootstrap/plan-9_8_1.json - hadrian/bootstrap/plan-9_8_2.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7e9b9c5fd79c402f609fd7dab2ea5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7e9b9c5fd79c402f609fd7dab2ea5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fix-use-std-ap-thunk] compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk
by Cheng Shao (＠TerrorJack) 14 Jul '26

14 Jul '26

Cheng Shao pushed to branch wip/fix-use-std-ap-thunk at Glasgow Haskell Compiler / GHC Commits: db03380d by Cheng Shao at 2026-07-13T19:34:33+02:00 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a typo in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> - - - - - 2 changed files: - + changelog.d/fix-use-std-ap-thunk - compiler/GHC/StgToCmm/Bind.hs Changes: ===================================== changelog.d/fix-use-std-ap-thunk ===================================== @@ -0,0 +1,4 @@ +section: codegen +synopsis: Fix redundant AP thunk codegen when not using -ticky-ap-thunk +issues: #27502 +mrs: !16340 ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -280,7 +280,7 @@ cgRhs id (StgRhsClosure fvs cc upd_flag args body _typ) = do profile <- getProfile check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig - use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig + use_std_ap_thunk <- not . stgToCmmTickyAP <$> getStgToCmmConfig mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body ------------------------------------------------------------------------ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db03380daf537bf29afdf65fc9128ea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db03380daf537bf29afdf65fc9128ea… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Major patch to re-engineer known-key names
by Rodrigo Mesquita (＠alt-romes) 14 Jul '26

14 Jul '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 50e96e26 by Simon Peyton Jones at 2026-07-13T18:12:34+01:00 Major patch to re-engineer known-key names This big patch implements the New Plan for known-key names, described in #27013. Read the big Note [Overview of known-key names] in GHC.Types.Name Some things had to be reworked slightly to accomodate the new known-keys design. A significant one was the generation of auxiliary KindRep bindings, which was greatly simplified. Note [Grand plan for Typeable] was updated accordingly. Another example: GHC.Internal.CString was merged into GHC.Internal.Types. Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> The couple hundreds of hours spent here by Rodrigo were sponsored by Well-Typed Metrics: compile_time/bytes allocated ------------------------------------- Baseline Test Metric value New value Change ------------------------------------------------------------------------------------------ MultiComponentModules100(normal) ghc/alloc 24,312,779,672 24,990,470,432 +2.8% BAD MultiComponentModulesRecomp(normal) ghc/alloc 601,924,960 621,884,888 +3.3% BAD MultiComponentModulesRecomp100(normal) ghc/alloc 11,884,065,432 12,531,373,704 +5.4% BAD MultiLayerModules(normal) ghc/alloc 3,861,537,072 3,706,919,512 -4.0% GOOD T13701(normal) ghc/alloc 3,517,246,392 3,237,179,616 -8.0% GOOD T13820(normal) ghc/alloc 28,961,056 29,663,208 +2.4% BAD T14697(normal) ghc/alloc 472,044,184 443,550,048 -6.0% GOOD T18140(normal) ghc/alloc 47,905,664 49,115,808 +2.5% BAD T4801(normal) ghc/alloc 269,339,096 263,432,040 -2.2% GOOD T783(normal) ghc/alloc 341,112,672 333,339,952 -2.3% GOOD hard_hole_fits(normal) ghc/alloc 222,164,728 213,433,808 -3.9% GOOD mhu-perf(normal) ghc/alloc 49,011,440 46,706,280 -4.7% GOOD geo. mean +0.1% minimum -8.0% maximum +5.4% All performance regressions were investigated in depth. The surviving ones: - MultiComponentModules100, MultiComponentModulesRecomp100, MultiComponentModulesRecomp regresses because existing bugs that make an additional implicit edge do too much redundant work: #27053 and #27461 - T13820, T18140, T10547, T13035 regress because we load an additional interface and associated Names for GHC.Essentials. ------------------------- Metric Decrease: MultiLayerModules T13701 T14697 T26989 T4801 T783 hard_hole_fits mhu-perf size_hello_obj Metric Increase: LinkableUsage01 MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 T10547 T13035 T13820 T18140 T20049 ------------------------- - - - - - 732 changed files: - + changelog.d/refactor-known-names - compiler/GHC.hs - + compiler/GHC/Builtin.hs - + compiler/GHC/Builtin/KnownKeys.hs - + compiler/GHC/Builtin/KnownOccs.hs - + compiler/GHC/Builtin/Modules.hs - − compiler/GHC/Builtin/Names.hs - − compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - + compiler/GHC/Builtin/TH.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - − compiler/GHC/Builtin/Utils.hs - + compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/Types/Prim.hs → compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/Types/Literals.hs → compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/Types.hs → compiler/GHC/Builtin/WiredIn/Types.hs - compiler/GHC/Builtin/Types.hs-boot → compiler/GHC/Builtin/WiredIn/Types.hs-boot - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/LiberateCase.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/KnotVars.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - − compiler/GHC/Iface/Env.hs-boot - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Plugins.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - − compiler/GHC/Utils/Binary/Typeable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/ghc.cabal.in - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/base/base.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Concurrent.hs - libraries/base/src/Control/Concurrent/Chan.hs - libraries/base/src/Control/Concurrent/QSem.hs - libraries/base/src/Control/Concurrent/QSemN.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bifoldable.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bifunctor.hs - libraries/base/src/Data/Bitraversable.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Complex.hs - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Contravariant.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/Data/Semigroup.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/ByteOrder.hs - + libraries/base/src/GHC/Essentials.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Numeric.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/CPUTime/Posix/ClockGetTime.hsc - libraries/base/src/System/CPUTime/Posix/RUsage.hsc - libraries/base/src/System/CPUTime/Unsupported.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/base/src/System/Info.hs - libraries/base/src/System/Timeout.hs - libraries/base/src/Text/Printf.hs - libraries/base/src/Text/Read.hs - libraries/base/src/Text/Show/Functions.hs - libraries/binary - libraries/ghc-experimental/src/Data/Sum/Experimental.hs - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-experimental/src/GHC/Profiling/Eras.hs - libraries/ghc-experimental/src/Prelude/Experimental.hs - libraries/ghc-internal/codepages/MakeTable.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/ArrayArray.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bits.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs - libraries/ghc-internal/src/GHC/Internal/Clock.hsc - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX/Const.hsc - libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Concurrent/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/IO/Class.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Data/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Dynamic.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Data/IORef.hs - libraries/ghc-internal/src/GHC/Internal/Data/List.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Data/Void.hs - libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs - libraries/ghc-internal/src/GHC/Internal/Desugar.hs - libraries/ghc-internal/src/GHC/Internal/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Environment.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Event/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Event/Array.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/IntTable.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/PSQ.hs - libraries/ghc-internal/src/GHC/Internal/Event/Poll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimeOut.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Clock.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/FFI.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/ExecutionStack.hs - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint/Type.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/ConversionUtils.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Types.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Alloc.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Array.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Pool.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Storable.hs - libraries/ghc-internal/src/GHC/Internal/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/GHCi.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs - libraries/ghc-internal/src/GHC/Internal/IO/BufferedIO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/API.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/Table.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Iconv.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Latin1.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF16.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF32.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Common.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Flock.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/NoOp.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/IO/SubSystem.hs - libraries/ghc-internal/src/GHC/Internal/IO/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc - libraries/ghc-internal/src/GHC/Internal/IOArray.hs - libraries/ghc-internal/src/GHC/Internal/IORef.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Magic/Dict.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - libraries/ghc-internal/src/GHC/Internal/Pack.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs - libraries/ghc-internal/src/GHC/Internal/Profiling.hs - libraries/ghc-internal/src/GHC/Internal/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Records.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/Stable.hs - libraries/ghc-internal/src/GHC/Internal/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/Storable.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Types.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadP.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadPrec.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/DerivedCoreProperties.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/GeneralCategory.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs - libraries/ghc-internal/src/GHC/Internal/Word.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/ghc-prim.cabal - libraries/template-haskell/Language/Haskell/TH/Lib.hs - rts/include/rts/RtsToHsIface.h - testsuite/tests/ado/T13242a.stderr - testsuite/tests/annotations/should_fail/annfail10.stderr - testsuite/tests/backpack/cabal/bkpcabal07/Makefile - testsuite/tests/backpack/should_compile/T20396.stderr - testsuite/tests/backpack/should_fail/bkpfail17.stderr - testsuite/tests/cabal/T12485/Makefile - + testsuite/tests/cabal/T27013a/Makefile - + testsuite/tests/cabal/T27013a/Setup.hs - + testsuite/tests/cabal/T27013a/all.T - + testsuite/tests/cabal/T27013a/composition.cabal - + testsuite/tests/cabal/T27013a/src/Data/Composition.hs - + testsuite/tests/cabal/T27013d/Composition.hs - + testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/cabal/T27013d/T27013d.stdout - + testsuite/tests/cabal/T27013d/all.T - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/corelint/LintEtaExpand.hs - testsuite/tests/corelint/T21115b.stderr - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/default/DefaultImportFail01.stderr - testsuite/tests/default/DefaultImportFail02.stderr - testsuite/tests/default/DefaultImportFail03.stderr - testsuite/tests/default/DefaultImportFail04.stderr - testsuite/tests/default/DefaultImportFail05.stderr - testsuite/tests/default/DefaultImportFail07.stderr - testsuite/tests/default/T25775.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/T20496.stderr - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/driver/T27013b/Makefile - + testsuite/tests/driver/T27013b/T27013b.stdout - + testsuite/tests/driver/T27013b/X.hs - + testsuite/tests/driver/T27013b/all.T - + testsuite/tests/driver/T27013c/Makefile - + testsuite/tests/driver/T27013c/T27013c.stdout - + testsuite/tests/driver/T27013c/X.hs - + testsuite/tests/driver/T27013c/all.T - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T - testsuite/tests/driver/T3007/A/Internal.hs - testsuite/tests/driver/T3007/Makefile - testsuite/tests/driver/make-prim/Makefile - testsuite/tests/driver/recomp24656/Makefile - testsuite/tests/driver/recomp24656/recomp24656.stdout - testsuite/tests/ghc-api/T8628.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghci.debugger/scripts/break006.stderr - testsuite/tests/ghci.debugger/scripts/print019.stderr - testsuite/tests/ghci/scripts/all.T - testsuite/tests/hiefile/should_run/T23120.stdout - testsuite/tests/iface/IfaceSharingIfaceType.hs - testsuite/tests/iface/IfaceSharingName.hs - testsuite/tests/indexed-types/should_fail/T12522a.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/javascript/T24495.hs - testsuite/tests/numeric/should_compile/T14170.stdout - testsuite/tests/numeric/should_compile/T14465.stdout - testsuite/tests/numeric/should_compile/T7116.stdout - testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr - testsuite/tests/package/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/T16270h.hs - testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr - testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs - testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/profiling/should_run/callstack002.stderr - testsuite/tests/profiling/should_run/callstack002.stdout - testsuite/tests/rename/should_compile/T3103/Foreign/Ptr.hs - testsuite/tests/rename/should_compile/T3103/GHC/Base.lhs - testsuite/tests/rename/should_compile/T3103/GHC/Word.hs - testsuite/tests/rename/should_compile/T3103/test.T - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T13543.stderr - testsuite/tests/simplCore/should_compile/T16038/T16038.stdout - testsuite/tests/simplCore/should_compile/T3717.stderr - testsuite/tests/simplCore/should_compile/T3772.stdout - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/T4930.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/T8274.stdout - testsuite/tests/simplCore/should_compile/T9400.stderr - testsuite/tests/simplCore/should_compile/noinline01.stderr - testsuite/tests/simplCore/should_compile/par01.stderr - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/simplCore/should_compile/str-rules.hs - testsuite/tests/tcplugins/ArgsPlugin.hs - testsuite/tests/tcplugins/EmitWantedPlugin.hs - testsuite/tests/tcplugins/RewritePlugin.hs - testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/TyFamPlugin.hs - testsuite/tests/th/T14741.hs - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T26568.stderr - testsuite/tests/th/TH_Roles2.stderr - + testsuite/tests/th/TH_pragmaSpecOld.hs - + testsuite/tests/th/TH_pragmaSpecOld.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T13032.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T15883b.stderr - testsuite/tests/typecheck/should_fail/T15883c.stderr - testsuite/tests/typecheck/should_fail/T15883d.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T5095.stderr - testsuite/tests/typecheck/should_fail/T7279.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_PatternBindingExistential.stderr - testsuite/tests/typecheck/should_fail/tcfail072.stderr - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/typecheck/should_fail/tcfail133.stderr - testsuite/tests/typecheck/should_run/T22510.stdout - testsuite/tests/unboxedsums/UbxSumLevPoly.hs - testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs - testsuite/tests/warnings/should_compile/DerivingTypeable.stderr - utils/check-exact/Utils.hs - utils/genprimopcode/Main.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50e96e2636b82bccd857a052f9438fa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50e96e2636b82bccd857a052f9438fa… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] 3 commits: Make output of cost center literals more precise
by Wolfgang Jeltsch (＠jeltsch) 14 Jul '26

14 Jul '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 4c81de9a by Wolfgang Jeltsch at 2026-07-13T17:53:40+03:00 Make output of cost center literals more precise - - - - - 5088065d by Wolfgang Jeltsch at 2026-07-13T20:09:37+03:00 Improve titles in breakpoint output - - - - - b9f1729b by Wolfgang Jeltsch at 2026-07-13T20:11:49+03:00 Remove offset from known-variable output - - - - - 1 changed file: - compiler/GHC/ByteCode/Show.hs Changes: ===================================== compiler/GHC/ByteCode/Show.hs ===================================== @@ -11,7 +11,7 @@ import Control.Exception (assert) import Data.Eq ((==)) import Data.Bits (FiniteBits, finiteBitSize) import Data.Function (($), id, (.)) -import Data.Tuple (uncurry) +import Data.Tuple (fst, uncurry) import Data.Bool (Bool, otherwise, not) import Data.Int (Int) import Data.Word (Word) @@ -191,7 +191,7 @@ pprLiteral currentModule literal = case literal of -> text "foreign function" <+> quotes (pprFFIInfo ffiInfo) BCONPtrCostCentre breakpointID - -> text "cost center" <+> + -> text "cost center of breakpoint" <+> pprInternalBreakpointID currentModule breakpointID -- | […] @@ -285,35 +285,35 @@ pprBreakpoints currentModule pprBreakpointsData :: Module -> InternalModBreaks -> SDoc pprBreakpointsData currentModule InternalModBreaks {..} = vcat [ - pprBreakpointsInSource currentModule $ imodBreaks_modBreaks, - pprBreakpointsInByteCode currentModule $ imodBreaks_breakInfo + pprSourceBreakpoints currentModule $ imodBreaks_modBreaks, + pprByteCodeBreakpoints currentModule $ imodBreaks_breakInfo ] -- | […] -pprBreakpointsInSource :: Module -> ModBreaks -> SDoc -pprBreakpointsInSource currentModule ModBreaks {..} - = entry (text "breakpoints in source") $ +pprSourceBreakpoints :: Module -> ModBreaks -> SDoc +pprSourceBreakpoints currentModule ModBreaks {..} + = entry (text "source breakpoints") $ assert (modBreaks_module == currentModule) $ assert (bounds modBreaks_locs_ == bounds modBreaks_decls) $ assert (bounds modBreaks_locs_ == bounds modBreaks_vars) $ vcatOrNone $ - zipWith4 pprBreakpointInSource (indices modBreaks_locs_) - (elems modBreaks_locs_) - (elems modBreaks_decls) - (elems modBreaks_vars) + zipWith4 pprSourceBreakpoint (indices modBreaks_locs_) + (elems modBreaks_locs_) + (elems modBreaks_decls) + (elems modBreaks_vars) -- The cost center infos in `modBreaks_ccs`, when present, just contain -- textual representations of the declaration paths in `modBreaks_decls` -- and the source spans in `modBreaks_locs_` and are therefore never -- shown. -- | […] -pprBreakpointInSource :: BreakTickIndex - -> BinSrcSpan - -> [String] - -> [OccName] - -> SDoc -pprBreakpointInSource ix srcSpan declarationPath freeVars - = entry (text "breakpoint" <+> ppr ix) $ +pprSourceBreakpoint :: BreakTickIndex + -> BinSrcSpan + -> [String] + -> [OccName] + -> SDoc +pprSourceBreakpoint ix srcSpan declarationPath freeVars + = entry (text "source breakpoint" <+> ppr ix) $ vcat [ pprSrcSpan $ srcSpan, pprDeclarationPath $ declarationPath, @@ -333,22 +333,22 @@ pprFreeVariables :: [OccName] -> SDoc pprFreeVariables = entry (text "free variables") . vcatOrNone . map ppr -- | […] -pprBreakpointsInByteCode :: Module -> IntMap CgBreakInfo -> SDoc -pprBreakpointsInByteCode currentModule - = entry (text "breakpoints in bytecode") . - vcatOrNone . - map (uncurry (pprBreakpointInByteCode currentModule)) . +pprByteCodeBreakpoints :: Module -> IntMap CgBreakInfo -> SDoc +pprByteCodeBreakpoints currentModule + = entry (text "bytecode breakpoints") . + vcatOrNone . + map (uncurry (pprByteCodeBreakpoint currentModule)) . IntMap.toList -- | […] -pprBreakpointInByteCode :: Module -> Int -> CgBreakInfo -> SDoc -pprBreakpointInByteCode currentModule ix CgBreakInfo {..} - = entry (text "breakpoint" <+> ppr ix) $ +pprByteCodeBreakpoint :: Module -> Int -> CgBreakInfo -> SDoc +pprByteCodeBreakpoint currentModule ix CgBreakInfo {..} + = entry (text "bytecode breakpoint" <+> ppr ix) $ vcat [ - pprType $ cgb_resty, - pprTypeVariables $ cgb_tyvars, - pprVariables $ cgb_vars, - pprOrigin currentModule $ cgb_tick_id + pprType $ cgb_resty, + pprTypeVariables $ cgb_tyvars, + pprVariables $ cgb_vars, + pprCorrespondingSourceBreakpoint currentModule $ cgb_tick_id ] -- That the 'cgb_resty' field holds the type of the breakpoint is apparent -- from the fact that this field is set by @@ -377,15 +377,7 @@ pprVariables = entry (text "variables") . vcatOrNone . map pprVariable -- | […] pprVariable :: Maybe (IfaceIdBndr, Word) -> SDoc -pprVariable = maybe (text "<unknown>") (uncurry pprKnownVariable) - -pprKnownVariable :: IfaceIdBndr -> Word -> SDoc -pprKnownVariable binder offset = pprVariableBinder binder <+> - text "@" <+> - ppr offset --- That the second argument is an offset is apparent from the use of the --- identifier @offset@ in the implementation of --- 'GHC.StgToByteCode.dehydrateCgBreakInfo'. +pprVariable = maybe (text "<unknown>") (pprVariableBinder . fst) -- | […] pprVariableBinder :: IfaceIdBndr -> SDoc @@ -393,10 +385,13 @@ pprVariableBinder (multiplicity, name, type_) = text "%" <> ppr multiplicity <+> ppr name <+> text "::" <+> ppr type_ -pprOrigin :: Module -> Either InternalBreakLoc BreakpointId -> SDoc -pprOrigin currentModule = entry (text "origin") . - pprBreakpointID currentModule . - either internalBreakLoc id +pprCorrespondingSourceBreakpoint :: Module + -> Either InternalBreakLoc BreakpointId + -> SDoc +pprCorrespondingSourceBreakpoint currentModule + = entry (text "corresponding source breakpoint") . + pprBreakpointID currentModule . + either internalBreakLoc id -- | […] [analogous to 'pprInternalBreakpointID' but the meaning of the index is different] pprBreakpointID :: Module -> BreakpointId -> SDoc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c461ef90e2cd36eb8c28b0de196b38… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c461ef90e2cd36eb8c28b0de196b38… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/supersven/hadrian-cross-stage3] 7 commits: WIP
by Sven Tennie (＠supersven) 14 Jul '26

14 Jul '26

Sven Tennie pushed to branch wip/supersven/hadrian-cross-stage3 at Glasgow Haskell Compiler / GHC Commits: b1983873 by Sven Tennie at 2026-07-13T19:14:30+02:00 WIP - - - - - 8d455fca by Sven Tennie at 2026-07-13T19:14:38+02:00 WIP - - - - - 998e2372 by Sven Tennie at 2026-07-13T19:14:47+02:00 WIP - - - - - 8c179fa9 by Sven Tennie at 2026-07-13T19:14:54+02:00 WIP - - - - - 946742b1 by Sven Tennie at 2026-07-13T19:15:00+02:00 Need configure.ac - - - - - 63f20eca by Sven Tennie at 2026-07-13T19:15:06+02:00 WIP - - - - - 4713cc0b by Sven Tennie at 2026-07-13T19:15:10+02:00 WIP - - - - - 4 changed files: - .gitignore - hadrian/src/BindistConfig.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== .gitignore ===================================== @@ -120,8 +120,6 @@ _darcs/ /compiler/GHC/CmmToLlvm/Version/Bounds.hs /compiler/ghc.cabal /compiler/ghc.cabal.old -/stage1/distrib/configure.ac -/stage2/distrib/configure.ac /distrib/ghc.iss /docs/index.html /docs/man ===================================== hadrian/src/BindistConfig.hs ===================================== @@ -3,28 +3,31 @@ module BindistConfig where import Stage import Oracles.Flag import Expression -data BindistConfig = BindistConfig - { library_stage :: Stage -- ^ The stage compiler which builds the libraries - , executable_stage :: Stage -- ^ The stage compiler which builds the executables - , bindistFolder :: FilePath -- ^ Parent folder under build root ("bindist" or "bindist-stage3") - } +data BindistConfig = BindistConfig { library_stage :: Stage -- ^ The stage compiler which builds the libraries + , executable_stage :: Stage -- ^ The stage compiler which builds the executables + } + -- | A bindist for when the host = target, non cross-compilation setting. -- Both the libraries and final executables are built with stage1 compiler. normalBindist :: BindistConfig -normalBindist = BindistConfig { library_stage = Stage1, executable_stage = Stage1, bindistFolder = "bindist" } +normalBindist = BindistConfig { library_stage = Stage1, executable_stage = Stage1 } -- | A bindist which contains a cross compiler (when host /= target) -- The cross compiler is produced by the stage1 compiler, but then we must compile -- all the boot libraries with the cross compiler (hence stage2 for libraries) crossBindist :: BindistConfig -crossBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage1, bindistFolder = "bindist" } +crossBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage1 } -- | A bindist which contains executables for the target, which produce code for the -- target. These are produced as "Stage3" build products, produced by a stage2 cross compiler. targetBindist :: BindistConfig -targetBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage2, bindistFolder = "bindist-stage3" } +targetBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage2 } +-- | Parent folder under build root ("bindist" or "bindist-stage3") +bindistFolder :: BindistConfig -> FilePath +bindistFolder conf | executable_stage conf == Stage2 = "bindist-stage3" +bindistFolder _conf = "bindist" -- | The implicit bindist config, if we don't know any better. implicitBindistConfig :: Action BindistConfig ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -6,7 +6,6 @@ import Context import Data.Either import qualified Data.Set as Set import Expression -import Hadrian.Oracles.Path (fixUnixPathsOnWindows) import Oracles.Flavour import Oracles.Setting import Packages @@ -14,8 +13,6 @@ import Rules.Generate (generateSettings) import Settings import qualified System.Directory.Extra as IO import Settings.Program (programContext) -import Target -import Utilities import BindistConfig {- @@ -168,7 +165,7 @@ buildBinDistDir root conf@BindistConfig{..} = do distDir <- Context.distDir (vanillaContext library_stage rts) let ghcBuildDir = root -/- stageString library_stage - bindistFilesDir = root -/- bindistFolder -/- ghcVersionPretty + bindistFilesDir = root -/- bindistFolder conf -/- ghcVersionPretty ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform rtsIncludeDir = distDir -/- "include" @@ -390,64 +387,34 @@ bindistRules = do phony "binary-dist-cross" $ buildBinDistX "binary-dist-dir-cross" "bindist" Xz phony "binary-dist-stage3" $ buildBinDistX "binary-dist-dir-stage3" "bindist-stage3" Xz - -- Prepare binary distribution configure script - -- (generated in a per-stage temporary distrib directory by 'autoreconf') - forM_ [("bindist", Stage1), ("bindist-stage3", Stage2)] $ \(folder, stage) -> - root -/- folder -/- "ghc-*" -/- "configure" %> generateConfigure root stage - - -- Generate the Makefile that enables the "make install" part - forM_ ["bindist", "bindist-stage3"] $ \folder -> - root -/- folder -/- "ghc-*" -/- "Makefile" %> \makefilePath -> do - top <- topDirectory - copyFile (top -/- "hadrian" -/- "bindist" -/- "Makefile") makefilePath - - -- Copy various configure-related files needed for a working - -- './configure [...] && make install' workflow - -- (see the list of files needed in the 'binary-dist' rule above, before - -- creating the archive). - forM_ ["bindist", "bindist-stage3"] $ \folder -> - forM_ bindistInstallFiles $ \file -> - root -/- folder -/- "ghc-*" -/- file %> \dest -> do - copyFile (fixup file) dest + forM_ [normalBindist, targetBindist] $ \bindistCfg -> do + let bindistFolderName = bindistFolder bindistCfg + stg = executable_stage bindistCfg + -- Copy the per-stage 'configure' (produced by autoreconf in Generate.hs) + -- from the build distrib dir into the bindist. Generating it there keeps + -- the autoreconf inputs (configure.ac, aclocal.m4, m4/*.m4) next to the + -- configure script and lets Shake track their changes correctly. + root -/- bindistFolderName -/- "ghc-*" -/- "configure" %> \configurePath -> do + let distribConfigure = root -/- stageString stg -/- "distrib" -/- "configure" + need [distribConfigure] + copyFile distribConfigure configurePath + + -- Generate the Makefile that enables the "make install" part + root -/- bindistFolderName -/- "ghc-*" -/- "Makefile" %> \makefilePath -> do + top <- topDirectory + copyFile (top -/- "hadrian" -/- "bindist" -/- "Makefile") makefilePath + + -- Copy various configure-related files needed for a working + -- './configure [...] && make install' workflow + -- (see the list of files needed in the 'binary-dist' rule above, before + -- creating the archive). + forM_ bindistInstallFiles $ \file -> + root -/- bindistFolderName -/- "ghc-*" -/- file %> \dest -> do + copyFile (fixup file) dest where fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f | otherwise = f - generateConfigure root stage configurePath = do - let acFile = stageString stage -/- "distrib" -/- "configure.ac" - need [acFile] - ghcRoot <- topDirectory - -- Use a per-stage temporary distrib directory so that Stage1 and - -- Stage2 configure generation can run concurrently without - -- clobbering each other's inputs/outputs. - let distribDir = root -/- ("distrib-" ++ stageString stage) - removeDirectory distribDir - createDirectory distribDir - copyFile (ghcRoot -/- acFile) (distribDir -/- "configure.ac") - copyFile (ghcRoot -/- "aclocal.m4") (distribDir -/- "aclocal.m4") - copyDirectory (ghcRoot -/- "m4") distribDir - - -- Note [Autoreconf unix paths from ACLOCAL_PATH] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- - -- style paths. This happens because MSYS2 automatically converts env variables to - -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. - -- This is done both in the boot Python script and here when building a bindist. - win_host <- isWinHost - env <- if not win_host - then pure [] - else do - aclocalPathMay <- getEnv "ACLOCAL_PATH" - case aclocalPathMay of - Nothing -> pure [] - Just aclocalPath -> do - unixAclocalPath <- fixUnixPathsOnWindows aclocalPath - pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] - - buildWithCmdOptions env $ - target (vanillaContext Stage1 ghc) (Autoreconf distribDir) [] [] - moveFile (distribDir -/- "configure") configurePath - removeDirectory distribDir data Compressor = Gzip | Bzip2 | Xz deriving (Eq, Ord, Show) ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -9,6 +9,7 @@ import qualified Data.Set as Set import Base import qualified Context import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) import Hadrian.Oracles.TextFile (lookupStageBuildConfig) import Oracles.Flag hiding (arSupportsAtFile, arSupportsDashL) import Oracles.ModuleFiles @@ -360,11 +361,6 @@ templateRule :: FilePath -> Interpolations -> Rules () templateRule outPath = templateRuleFrom (outPath <.> "in") outPath -templateRuleForStages :: FilePath -> (Stage -> Interpolations) -> Rules () -templateRuleForStages outPath mkInterps = - forM_ [Stage1, Stage2] $ \stage -> - templateRuleFrom (outPath <.> "in") (stageString stage -/- outPath) (mkInterps stage) - templateRules :: Rules () templateRules = do templateRule "compiler/ghc.cabal" $ projectVersion @@ -415,6 +411,7 @@ templateRules = do bindistRules :: Rules () bindistRules = do + root <- buildRootRules templateRule ("mk" -/- "project.mk") $ mconcat [ interpolateSetting "ProjectName" ProjectName , interpolateSetting "ProjectVersion" ProjectVersion @@ -426,45 +423,125 @@ bindistRules = do , interpolateVar "HostOS_CPP" $ fmap cppify $ interp $ queryHost queryOS - , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple - , interpolateVar "TargetPlatform_CPP" $ cppify <$> getTarget targetPlatformTriple - , interpolateVar "TargetArch_CPP" $ cppify <$> getTarget queryArch - , interpolateVar "TargetOS_CPP" $ cppify <$> getTarget queryOS - , interpolateVar "LLVMTarget" $ getTarget tgtLlvmTarget + -- Stage2 always targets the final architecture. Thus, we can use a + -- constant stage here. + , interpolateVar "TargetPlatform" $ getTarget Stage2 targetPlatformTriple + , interpolateVar "TargetPlatform_CPP" $ cppify <$> getTarget Stage2 targetPlatformTriple + , interpolateVar "TargetArch_CPP" $ cppify <$> getTarget Stage2 queryArch + , interpolateVar "TargetOS_CPP" $ cppify <$> getTarget Stage2 queryOS + , interpolateVar "LLVMTarget" $ getTarget Stage2 tgtLlvmTarget ] - templateRuleForStages ("distrib" -/- "configure.ac") $ \stage -> mconcat + forM_ [Stage1, Stage2] $ \stage -> + let crossStageInterps = Interpolations $ do + isCrossStage <- crossStage stage + targetPlatform <- setting TargetPlatformFull + -- For cross-compiled compilers we need to pretend that they were + -- build on the target. For regular commpilers we can assume that: + -- build == host == target + buildPlatform <- + if isCrossStage + then + interp $ queryBuild targetPlatformTriple + else getTarget stage targetPlatformTriple + hostPlatform <- + if isCrossStage + then + interp $ queryHost targetPlatformTriple + else getTarget stage targetPlatformTriple + baseUnitId <- pkgUnitId (if isCrossStage then succStage stage else stage) base + buildPlatformFull <- if isCrossStage then setting BuildPlatformFull else setting TargetPlatformFull + hostPlatformFull <- if isCrossStage then setting HostPlatformFull else setting TargetPlatformFull + pure + [ ("CrossCompilePrefix", if isCrossStage then targetPlatform <> "-" else "") + , ("TargetPlatformFull", targetPlatform) + , ("BuildPlatform", buildPlatform) + , ("HostPlatform", hostPlatform) + , ("BaseUnitId", baseUnitId) + , ("BuildPlatformFull", buildPlatformFull) + , ("HostPlatformFull", hostPlatformFull) + ] + in templateRuleFrom + ("distrib" -/- "configure.ac" <.> "in") + (root -/- stageString stage -/- "distrib" -/- "configure.ac") + $ mconcat [ interpolateSetting "ConfiguredEmsdkVersion" EmsdkVersion - , interpolateVar "CrossCompilePrefix" $ do - isCross <- crossStage stage - target <- setting TargetPlatformFull - pure $ if isCross then target <> "-" else "" - , interpolateVar "LeadingUnderscore" $ yesNo <$> getTarget tgtSymbolsHaveLeadingUnderscore + , interpolateVar "LeadingUnderscore" $ yesNo <$> getTarget stage tgtSymbolsHaveLeadingUnderscore , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion , interpolateSetting "LlvmMinVersion" LlvmMinVersion - , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget + , interpolateVar "LlvmTarget" $ getTarget stage tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion , interpolateVar "EnableDistroToolchain" $ interp (staged (lookupStageBuildConfig "settings-use-distro-mingw")) - , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode + , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget stage tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ yesNo <$> interp (staged (buildFlag TargetHasLibm)) - , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple - , interpolateVar "BuildPlatform" $ ifM (not <$> crossStage stage) (getTarget targetPlatformTriple) (interp $ queryBuild targetPlatformTriple) - , interpolateVar "HostPlatform" $ ifM (not <$> crossStage stage) (getTarget targetPlatformTriple) (interp $ queryHost targetPlatformTriple) - , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian - , interpolateVar "TargetWordSize" $ getTarget wordSize - , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised + , interpolateVar "TargetPlatform" $ getTarget stage targetPlatformTriple + , interpolateVar "TargetWordBigEndian" $ getTarget stage isBigEndian + , interpolateVar "TargetWordSize" $ getTarget stage wordSize + , interpolateVar "Unregisterised" $ yesNo <$> getTarget stage tgtUnregisterised , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ staged (fmap (isJust . tgtRTSWithLibdw) . targetStage) - , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors - , interpolateVar "BaseUnitId" $ do - isCross <- crossStage stage - pkgUnitId (if isCross then succStage stage else stage) base - , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP Stage2 - , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull) - , interpolateVar "BuildPlatformFull" $ ifM (not <$> crossStage stage) (setting TargetPlatformFull) (setting BuildPlatformFull) - , interpolateVar "HostPlatformFull" $ ifM (not <$> crossStage stage) (setting TargetPlatformFull) (setting HostPlatformFull) + , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget stage tgtUseLibffiForAdjustors + , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP stage + , crossStageInterps ] + + -- Stage the autoreconf inputs (aclocal.m4 and the m4/ macro directory) next + -- to each per-stage generated configure.ac under _build, then run + -- 'autoreconf' to produce a per-stage 'configure' script there. + -- + -- The 'Autoreconf' builder auto-needs <dir>/configure.ac (Builder.hs); we + -- also explicitly need the staged macros so editing them triggers + -- re-generation of 'configure'. BinaryDist.hs copies this configure into + -- the bindist; it no longer runs autoreconf itself. + forM_ [Stage1, Stage2] $ \stage -> do + let distribDir = root -/- stageString stage -/- "distrib" + + distribDir -/- "aclocal.m4" %> \out -> do + top <- topDirectory + copyFile (top -/- "aclocal.m4") out + + -- Autoconf auxiliary files required by autoreconf (config.sub, + -- config.guess, install-sh). They live in-tree at the repo root and must + -- be staged next to configure.ac for autoreconf to find them. + forM_ ["config.sub", "config.guess", "install-sh"] $ \f -> + distribDir -/- f %> \out -> do + top <- topDirectory + copyFile (top -/- f) out + + distribDir -/- "m4/*.m4" %> \out -> do + top <- topDirectory + copyFile (top -/- "m4" -/- takeFileName out) out + + distribDir -/- "configure" %> \_ -> do + top <- topDirectory + m4Files <- getDirectoryFiles (top -/- "m4") ["*.m4"] + need $ [ distribDir -/- "configure.ac" + , distribDir -/- "config.sub" + , distribDir -/- "config.guess" + , distribDir -/- "install-sh" + , distribDir -/- "aclocal.m4" + ] + ++ [ distribDir -/- "m4" -/- takeFileName f | f <- m4Files ] + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable + -- contains Windows-style paths. MSYS2 auto-converts env vars to + -- Windows-style, so we convert ACLOCAL_PATH back to Unix style here. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ + target (vanillaContext stage ghc) (Autoreconf distribDir) [] [] where interp = interpretInContext (semiEmptyTarget Stage2) - getTarget = interp . queryTarget Stage2 + getTarget stage = interp . queryTarget stage -- | Given a 'String' replace characters '.' and '-' by underscores ('_') so that -- the resulting 'String' is a valid C preprocessor identifier. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58e8070e93dfb897aec41098d456ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58e8070e93dfb897aec41098d456ee… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27461] downsweep: make control flow simpler and cache correct
by Rodrigo Mesquita (＠alt-romes) 13 Jul '26

13 Jul '26

Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC Commits: 5eb79ca6 by Rodrigo Mesquita at 2026-07-13T17:31:57+01:00 downsweep: make control flow simpler and cache correct This refactor extracts the control flow of downsweep into a single function `dfsBuild`, which takes care of iteratively expanding and traversing all nodes of the in-construction module graph necessary to build a full `ModuleGraph`. There are three levels of caching going on, all of which are necessary to make sure we don't do repeated work (notably, NEVER summarise the same module twice). 1. `dfsBuild` accumulates the final module graph and never revisits the same node of the module graph. Cache is keyed by the final `ModuleGraph`s `NodeKey`s. 2. For Module A in home-unit u1, each import in the list of imports needs to be *found* (call to `findImportedModuleWithIsBoot`): at this point, we only have the `ModuleName` of the import, not the `Module`. This *finding* is somewhat expensive, so we cache it as well (`ImportsCache`). The cache key is the home-unit to which the module belongs~[1], the import package qualifier, and the ModuleName. [1] Different home-units will have different package flags, which means potentially different `Module` resolution for the same `ModuleName`. 3. The most expensive operation we want to avoid is summarising a `Module` into a `ModSummary`, which notably involves parsing the module header from scratch. The third cache, in essence, maps a `Module` to its `ModSummary` (named `ModSummaryCache`). This cache upholds the invariant: we NEVER summarise the same module twice. In practice, the cache key is the Module's UnitId and the Source path; the reason is we need to distinguish between `.hs` and `.hs-boot` files, as their summaries will differ. Note that (2) can't guarantee this alone: Two ModuleName imports in separate units can (and likely do) map to the same `Module`. Note that the previous implementation failed to achieve the no-duplicate-work summarisation invariant, and we ended up doing a quadratic amount of processing in scenarios like test `MultiComponentModules100`. See also Note [Downsweep Control Flow and Caching] Fixes #27461 Perf changes: MultiComponentModules(normal) ghc/alloc 2,097,389,264 1,992,186,736 -5.0% GOOD MultiComponentModules100(normal) ghc/alloc 24,310,173,770 21,293,867,360 -12.4% GOOD MultiComponentModulesRecomp(normal) ghc/alloc 602,761,394 498,543,984 -17.3% GOOD MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,968,240 8,895,404,864 -25.2% GOOD ------------------------- Metric Decrease: MultiComponentModules MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 ------------------------- - - - - - 6 changed files: - compiler/GHC/Driver/Downsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -5,6 +5,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk @@ -91,7 +93,7 @@ import GHC.Unit.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage -import Data.Either ( rights, partitionEithers, lefts ) +import Data.Either ( partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -111,6 +113,8 @@ import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class import System.IO.Unsafe (unsafeInterleaveIO) +import Data.IORef +import qualified Data.List.NonEmpty as NE {- Note [Downsweep and the ModuleGraph] @@ -142,14 +146,6 @@ The result is having a uniform graph available for the whole compilation pipelin -} --- This caches the answer to the question, if we are in this unit, what does --- an import of this module mean. -type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] - -moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode -moduleGraphNodeMap graph - = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] - ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) for --make mode @@ -195,8 +191,11 @@ downsweep :: HscEnv -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do - n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) + summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld))) + imps_cache <- newIORef Map.empty + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg + (getRootSummary excl_mods summ_cache imps_cache) let closure_errs = checkHomeUnitsClosed unit_env unit_env = hsc_unit_env hsc_env @@ -204,9 +203,13 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo case all_errs of [] -> do - (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + (downsweep_errs, downsweep_nodes) <- + downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph + excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] - let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + let (other_errs, unit_nodes) = partitionEithers $ + HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] + (hsc_HUG hsc_env) let all_nodes = downsweep_nodes ++ unit_nodes let all_errs = downsweep_errs ++ other_errs @@ -222,17 +225,6 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo return (all_errs, th_configured_nodes) _ -> return (all_errs, emptyMG) where - summary = getRootSummary excl_mods old_summary_map - - -- A cache from file paths to the already summarised modules. The same file - -- can be used in multiple units so the map is also keyed by which unit the - -- file was used in. - -- Reuse these if we can because the most expensive part of downsweep is - -- reading the headers. - old_summary_map :: M.Map (UnitId, OsPath) ModSummary - old_summary_map = - M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries] - -- Dependencies arising on a unit (backpack and module linking deps) unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] unitModuleNodes summaries uid hue = @@ -245,7 +237,9 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." - ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)]) + imps <- newIORef mempty + ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] let dflags = hsc_dflags hsc_env liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) (initPrintConfig dflags) @@ -269,83 +263,22 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") let imps = ic_imports (hsc_IC hsc_env) - let interactive_mn = icInteractiveModule ic - -- No sensible value for ModLocation.. if you hit this panic then you probably - -- need to add proper support for modules without any source files to the driver. - let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps) - let key = moduleToMnk interactive_mn NotBoot - let node_type = ModuleNodeFixed key ml + interactive_mn = icInteractiveModule ic + key = dsNodeInfoKey (DSInteractive interactive_mn imps) -- The existing nodes in the module graph. This will be populated when GHCi runs -- :load. Any home package modules need to already be in here. let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] - (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes - let interactive_node = ModuleNode module_edges node_type - - let all_nodes = M.elems graph + summ_cache <- newIORef mempty + imps_cache <- newIORef mempty + let env = DownsweepEnv hsc_env DownsweepUseFixed{-or UseCompiled?-} summ_cache imps_cache [] + graph <- runDownsweepM env do + loopFromInteractive cached_nodes interactive_mn imps + let interactive_node = expectJust $ M.lookup key graph + all_nodes = M.elems graph return $ mkModuleGraph (interactive_node : all_nodes) - where - -- - mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) - -- A simple edge to a module from the same home unit - mkEdge (IIModule n) = - let - mod_node_key = ModNodeKeyWithUid - { mnkModuleName = GWIB (moduleName n) NotBoot - , mnkUnitId = - -- 'toUnitId' is safe here, as we can't import modules that - -- don't have a 'UnitId'. - toUnitId (moduleUnit n) - } - mod_node_edge = - ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) - in Left mod_node_edge - -- A complete import statement - mkEdge (IIDecl i) = - let lvl = convImportLevel (ideclLevelSpec i) - wanted_mod = unLoc (ideclName i) - is_boot = ideclSource i - mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) - unitId = homeUnitId $ hsc_home_unit hsc_env - in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) - -loopFromInteractive :: HscEnv - -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] - -> M.Map NodeKey ModuleGraphNode - -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) -loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) -loopFromInteractive hsc_env (edge:edges) cached_nodes = - case edge of - Left edge -> do - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes - return (edge : edges, cached_nodes') - Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do - let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) - let k _ loc mod = - let key = moduleToMnk mod is_boot - in return $ FoundHome (ModuleNodeFixed key loc) - found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] - case found of - -- Case 1: Home modules have to already be in the cache. - FoundHome (ModuleNodeFixed mod _) -> do - let edge = ModuleNodeEdge lvl (NodeKey_Module mod) - -- Note: Does not perform any further downsweep as the module must already be in the cache. - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes - return (edge : edges, cached_nodes') - -- Case 2: External units may not be in the cache, if we haven't already initialised the - -- module graph. We can construct the module graph for those here by calling loopUnit. - External uid -> do - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - cached_nodes' = loopUnit hsc_env' cached_nodes [uid] - edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' - return (edge : edges, cached_nodes') - -- And if it's not found.. just carry on and hope. - _ -> loopFromInteractive hsc_env edges cached_nodes - - -- | Create a module graph from a list of installed modules. -- This is used by the loader when we need to load modules but there -- isn't already an existing module graph. For example, when loading plugins @@ -373,7 +306,9 @@ downsweepInstalledModules hsc_env mods = do _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i nodes <- mapM process installed_mods - (errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed nodes external_uids + summs <- newIORef mempty + imps <- newIORef mempty + (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids -- Similarly here, we should really not get any errors, but print them out if we do. let dflags = hsc_dflags hsc_env @@ -397,7 +332,8 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- This function will start at the given roots, and traverse downwards to find -- all the dependencies, all the way to the leaf units. downsweepFromRootNodes :: HscEnv - -> M.Map (UnitId, OsPath) ModSummary + -> ModSummaryCache + -> ImportsCache -> Maybe ModuleGraph -> [ModuleName] -> Bool @@ -405,44 +341,48 @@ downsweepFromRootNodes :: HscEnv -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo -> [UnitId] -- ^ The starting units -> IO ([DriverMessages], [ModuleGraphNode]) -downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids - = do - let root_map = mkRootMap root_nodes - checkDuplicates root_map - let env = DownsweepEnv hsc_env mode old_summaries excl_mods - (deps', map0) <- runDownsweepM env $ do - let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph - (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map) - let all_deps = loopUnit hsc_env module_deps root_uids - let all_instantiations = getHomeUnitInstantiations hsc_env - deps' <- loopInstantiations all_instantiations all_deps - return (deps', map0) - - - let downsweep_errs = lefts $ concat $ M.elems map0 - downsweep_nodes = M.elems deps' - - return (downsweep_errs, downsweep_nodes) - where - getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] - getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates - :: DownsweepCache - -> IO () - checkDuplicates root_map - | not allow_dup_roots - , dup_root:_ <- dup_roots = liftIO $ multiRootsErr sec dup_root - | otherwise = pure () - where - sec = initSourceErrorContext (hsc_dflags hsc_env) - dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights (M.elems root_map) - +downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do + when (not allow_dup_roots) $ + case root_duplicates of + [] -> return () + (dup_root:_) -> multiRootsErr sec dup_root + modifyImpsCache imps_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache + let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods + deps' <- runDownsweepM env $ do + let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph + module_deps <- loopModuleNodeInfos base_nodes root_nodes + all_deps <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids + deps' <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env) + return deps' + f_cache <- readIORef summ_cache + let downsweep_errs = lefts (M.elems f_cache) + downsweep_nodes = M.elems deps' + + return (downsweep_errs, downsweep_nodes) + where + getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] + getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey + (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + root_duplicates :: [NE.NonEmpty ModuleNodeInfo] + root_duplicates = mapMaybe takes2 (M.elems root_map) + where + takes2 (a:as@(_:_)) = Just (a NE.:| as) -- Each at least of length 2 + takes2 _ = Nothing + + root_map = Map.fromListWith (flip (++)) + [ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s]) + | s <- root_nodes ] + + moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode + moduleGraphNodeMap graph + = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + + sec = initSourceErrorContext (hsc_dflags hsc_env) calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] calcDeps ms = @@ -457,104 +397,292 @@ type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { downsweep_hsc_env :: HscEnv , _downsweep_mode :: DownsweepMode - , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary + , _downsweep_summaries_cache :: ModSummaryCache + , downsweep_imports_cache :: ImportsCache , _downsweep_excl_mods :: [ModuleName] } +type ModSummaryCache = IORef ModSummaryCacheMap +type ImportsCache = IORef ImportsCacheMap + +-- | A cache from file paths to the already summarised modules. The same file +-- can be used in multiple units so the map is actually also keyed by which +-- unit the file was used in. +-- +-- We want to reuse ModSummaries as far as possible because the most expensive +-- part of downsweep is reading and parsing the headers. +-- +-- See Note [Downsweep Control Flow and Caching] +type ModSummaryCacheMap + -- The cache can't be keyed by 'Module' because that isn't sufficient to + -- distinguish .hs from .hs-boot files. Use path+unit instead. + = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) ) + +data SummProvenance + -- | Constructed during this downsweep: trivially up to date + = SummFresh + -- | Carried over from a previous run: may be stale, must be hash-checked + -- (and considered by -fforce-recomp) + | SummOld + +mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap +mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs + +addModSummaryCache :: ModSummary -> SummProvenance -> ModSummaryCacheMap -> ModSummaryCacheMap +addModSummaryCache ms pr fe = upd_fe fe + where + upd_fe fe + | Just src_fn_os <- ml_hs_file_ospath (ms_location ms) + = M.insert (ms_unitid ms, src_fn_os) (Right (ms, pr)) fe + | otherwise = fe + +modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO () +modifyImpsCache :: ImportsCache -> (ImportsCacheMap -> ImportsCacheMap) -> IO () +modifySummCache r f = atomicModifyIORef' r (\c -> (f c, ())) +modifyImpsCache r f = atomicModifyIORef' r (\c -> (f c, ())) + +-- | A cache from a module import (in given home unit context, with a package +-- qualifier, and the imported module name (with or without SOURCE)) to the +-- result of summarising that import (see 'summariseModuleDispatch'). +-- +-- See Note [Downsweep Control Flow and Caching] +type ImportsCacheMap + = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) SummariseResult + +-- | Populate the 'ImportsCacheMap' with the root modules. +mkRootMap :: [ModuleNodeInfo] -> ImportsCacheMap +mkRootMap summaries = Map.fromList + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), FoundHome s) | s <- summaries ] + runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a runDownsweepM env act = runReaderT act env +loopDownsweepNodes :: M.Map NodeKey ModuleGraphNode -> [DownsweepNode] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopModuleNodeInfos :: M.Map NodeKey ModuleGraphNode -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopUnits :: M.Map NodeKey ModuleGraphNode -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations :: M.Map NodeKey ModuleGraphNode -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFromInteractive :: M.Map NodeKey ModuleGraphNode -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand +loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod +loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud) +loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst) +loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m + +-------------------------------------------------------------------------------- + +-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which +-- encompasses the types of nodes we can iteratively expand to construct the +-- full module graph. See 'loopDownsweepNodes'. +-- +-- See Note [Downsweep Control Flow and Caching] +data DownsweepNode + -- | A module node to expand + = DSMod ModuleNodeInfo + -- | A unit node to expand + | DSUnit + { home_context_uid :: UnitId + -- ^ The home unit which introduced the dependency on this 'node_uid'. This + -- 'node_uid' can only be expanded in the context ('HscEnv') where + -- 'home_context_uid' is the active home unit, to make sure the package flags + -- are the ones attributed to the home package that introduced this node. + , node_uid :: UnitId + -- ^ The unit node to expand + } + -- | FIXME: document the meaning of 'DSInst' + | DSInst + { home_context_uid :: UnitId + , instantiated_ud :: InstantiatedUnit + } + -- | A group of interactive imports from this interactive Module + | DSInteractive Module [InteractiveImport] + +instance Outputable DownsweepNode where + ppr = \case + DSMod (ModuleNodeCompile ms) -> text "DSModC" <+> ppr (ms_mod_name ms) + DSMod (ModuleNodeFixed key _) -> text "DSModF" <+> ppr key + DSUnit{node_uid} -> text "DSUnit" <+> ppr node_uid + DSInst{instantiated_ud} -> text "DSInst" <+> ppr instantiated_ud + DSInteractive mod ii -> text "DSInteractive" <+> ppr mod <+> ppr ii + +-- | They key by which to cache previously visited 'DownsweepNode's +dsNodeInfoKey :: DownsweepNode -> NodeKey +dsNodeInfoKey = \case + DSMod (ModuleNodeCompile ms) -> NodeKey_Module (msKey ms) + DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod + DSUnit{node_uid} -> NodeKey_ExternalUnit node_uid + DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud + DSInteractive mod _imps -> NodeKey_Module $ moduleToMnk mod NotBoot + +dsNodeExpand :: DownsweepNode -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +dsNodeExpand = \case + DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms + DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc + DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid + DSInst{ instantiated_ud + , home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid + DSInteractive imod iis -> expandInteractiveImports imod iis + +expandModuleSummary :: ModSummary -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that. + hsc_env <- asks downsweep_hsc_env + let home_uid = ms_unitid ms + home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do + let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing + case mb_s of + NotThere -> return + ( Nothing, [] ) + External uid -> return + ( Just $ mkModuleEdge imp (NodeKey_ExternalUnit uid) + -- Specify home unit, as each unit might have a different visible package database. + , [DSUnit{node_uid = uid, home_context_uid = home_uid}] ) + FoundInstantiation iud -> return + ( Just (mkModuleEdge imp (NodeKey_Unit iud)), [] ) + FoundHomeWithError (_uid, _e) -> return + ( Nothing, [] ) + -- the error @e@ is already stored in the summarisation cache, + -- (the IORef in DownsweepM) and will get reported at the end. + FoundHome s -> return + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s)) + , [DSMod s] ) + + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + boot_todo <- + if | HsBootFile <- ms_hsc_src ms + -> do + r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing + case r of + FoundHome s -> pure [DSMod s] + _ -> pure [] + | otherwise -> pure [] + + return $ Just + ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms) + , boot_todo ++ concat todo + ) + +-- | Expand a 'ModuleNodeFixed' node +-- NB: If you ever reach a Fixed node, everything under that also must be fixed. +expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandFixedModuleNode key loc = do + hsc_env <- asks downsweep_hsc_env + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- liftIO $ + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map mkFixedEdge node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps) + pure $ Just (node, deps') + + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + pure Nothing + where + mk_dep hsc_env (Left key) = do + -- Like expandImports, but we already know exactly which module we are looking for. + read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + pure $ Just $ DSMod (ModuleNodeFixed key loc) + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + pure Nothing + mk_dep _ (Right uid_dep) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + let home_uid = mnkUnitId key + pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid}) + +-- | Expand a unit id under the context of a certain home unit +expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -} + -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandUnitNode node_uid home_context_uid = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + hsc_env <- asks downsweep_hsc_env + let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env + case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of + Just us -> pure $ Just ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us) + Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid) + +expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandInstantiatedUnit iud home_uid = pure $ Just + ( InstantiationNode home_uid iud + , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] ) + +expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandInteractiveImports imod imps = do + hsc_env <- asks downsweep_hsc_env + imps_cache <- asks downsweep_imports_cache + + let + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = return $ + let + mod_node_key = ModNodeKeyWithUid + { mnkModuleName = GWIB (moduleName n) NotBoot + , mnkUnitId = + -- 'toUnitId' is safe here, as we can't import modules that + -- don't have a 'UnitId'. + toUnitId (moduleUnit n) + } + in (Just $ ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key), []) -loopInstantiations :: [(UnitId, InstantiatedUnit)] - -> M.Map NodeKey ModuleGraphNode - -> DownsweepM (M.Map NodeKey ModuleGraphNode) -loopInstantiations [] done = pure done -loopInstantiations ((home_uid, iud) :xs) done = do - hsc_env <- asks downsweep_hsc_env - let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - done' = loopUnit hsc_env' done [instUnitInstanceOf iud] - payload = InstantiationNode home_uid iud - loopInstantiations xs (M.insert (mkNodeKey payload) payload done') - - --- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit -loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, - DownsweepCache) - -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) -loopSummaries [] done = pure done -loopSummaries (ms:next) (done, summarised) - | Just {} <- M.lookup k done - = loopSummaries next (done, summarised) - -- Didn't work out what the imports mean yet, now do that. - | otherwise = do - (final_deps, done', summarised') <- loopImports (ms_unitid ms) (calcDeps ms) done summarised - -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, done'', summarised'') <- loopImports (ms_unitid ms) (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + -- A complete import statement + mkEdge (IIDecl i) = + let lvl = convImportLevel (ideclLevelSpec i) + wanted_mod = unLoc (ideclName i) + is_boot = ideclSource i + mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + unitId = homeUnitId $ hsc_home_unit hsc_env + in do + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + + found <- liftIO $ summariseModuleDispatch k hsc_env imps_cache + home_unit is_boot (noLoc wanted_mod) mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + -- Note: Does not perform any further downsweep as the module must already be in the cache. + return (Just edge, []) + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. We can construct the module graph for those here by calling loopUnit. + External uid -> do + let edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + return (Just edge, [DSUnit{node_uid=uid, home_context_uid=homeUnitId home_unit}]) + -- And if it's not found.. just carry on and hope. + _ -> return (Nothing, []) + + (module_edges, todo) <- unzip <$> mapM mkEdge imps + pure $ Just + ( ModuleNode (catMaybes module_edges) node_type, concat todo ) where - k = NodeKey_Module (msKey ms) + -- No sensible value for ModLocation.. if you hit this panic then you probably + -- need to add proper support for modules without any source files to the driver. + ml = pprPanic "modLocation" (ppr imod <+> ppr imps) + key = moduleToMnk imod NotBoot + node_type = ModuleNodeFixed key ml - hs_file_for_boot - | HsBootFile <- ms_hsc_src ms - = Just (NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) - | otherwise - = Nothing - -loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) -loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is - -loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) -loopModuleNodeInfo mod_node_info (done, summarised) = do - case mod_node_info of - ModuleNodeCompile ms -> do - loopSummaries [ms] (done, summarised) - ModuleNodeFixed mod ml -> do - done' <- loopFixedModule mod ml done - return (done', summarised) - --- NB: loopFixedModule does not take a downsweep cache, because if you --- ever reach a Fixed node, everything under that also must be fixed. -loopFixedModule :: ModNodeKeyWithUid -> ModLocation - -> M.Map NodeKey ModuleGraphNode - -> DownsweepM (M.Map NodeKey ModuleGraphNode) -loopFixedModule key loc done = do - let nk = NodeKey_Module key - hsc_env <- asks downsweep_hsc_env - case M.lookup nk done of - Just {} -> return done - Nothing -> do - -- MP: TODO, we should just read the dependency info from the interface rather than either - -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) - -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) - read_result <- liftIO $ - -- 1. Check if the interface is already loaded into the EPS by some other - -- part of the compiler. - lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case - Just iface -> return (M.Succeeded iface) - Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) - case read_result of - M.Succeeded iface -> do - -- Computer information about this node - let node_deps = ifaceDeps (mi_deps iface) - edges = map mkFixedEdge node_deps - node = ModuleNode edges (ModuleNodeFixed key loc) - foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) - -- Ignore any failure, we might try to read a .hi-boot file for - -- example, even if there is not one. - M.Failed {} -> - return done - -loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode) -loopFixedNodeKey _ done (Left key) = do - loopFixedImports [key] done -loopFixedNodeKey home_uid done (Right uid) = do - -- Set active unit so that looking loopUnit finds the correct - -- -package flags in the unit state. - hsc_env <- asks downsweep_hsc_env - let hsc_env' = hscSetActiveUnitId home_uid hsc_env - return $ loopUnit hsc_env' done [uid] +-------------------------------------------------------------------------------- mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) @@ -569,27 +697,6 @@ ifaceDeps deps = | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) ] --- Like loopImports, but we already know exactly which module we are looking for. -loopFixedImports :: [ModNodeKeyWithUid] - -> M.Map NodeKey ModuleGraphNode - -> DownsweepM (M.Map NodeKey ModuleGraphNode) -loopFixedImports [] done = pure done -loopFixedImports (key:keys) done = do - let nk = NodeKey_Module key - hsc_env <- asks downsweep_hsc_env - case M.lookup nk done of - Just {} -> loopFixedImports keys done - Nothing -> do - read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) - case read_result of - InstalledFound loc -> do - done' <- loopFixedModule key loc done - loopFixedImports keys done' - _otherwise -> - -- If the finder fails, just keep going, there will be another - -- error later. - loopFixedImports keys done - downsweepSummarise :: HomeUnit -> IsBootInterface -> Located ModuleName @@ -597,90 +704,22 @@ downsweepSummarise :: HomeUnit -> Maybe (StringBuffer, UTCTime) -> DownsweepM SummariseResult downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do - DownsweepEnv hsc_env mode old_summaries excl_mods <- ask - case mode of - DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods - DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods - - --- This loops over each import in each summary. It is mutually recursive with --- loopSummaries if we discover a new module by doing this. -loopImports - :: UnitId - -- ^ UnitId of home unit of summary whose imports are being processed - -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] - -- ^ Work list: process these modules - -> M.Map NodeKey ModuleGraphNode - -> DownsweepCache - -- ^ Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> DownsweepM ([ModuleNodeEdge], - M.Map NodeKey ModuleGraphNode, DownsweepCache) - -- ^ The result is the completed NodeMap -loopImports _ [] done summarised = return ([], done, summarised) -loopImports home_uid ((imp, mb_pkg, gwib) : ss) done summarised - | Just summs <- M.lookup cache_key summarised - = case summs of - [Right ms] -> do - let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) - (rest, summarised', done') <- loopImportsNext done summarised - return (nk: rest, summarised', done') - [Left _err] -> - loopImportsNext done summarised - _errs -> do - loopImportsNext done summarised - | otherwise - = do - hsc_env <- asks downsweep_hsc_env - let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - mb_s <- downsweepSummarise home_unit - is_boot wanted_mod mb_pkg - Nothing - case mb_s of - NotThere -> loopImportsNext done summarised - External uid -> do - -- Pass an updated hsc_env to loopUnit, as each unit might - -- have a different visible package database. - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - let done' = loopUnit hsc_env' done [uid] - (other_deps, done'', summarised') <- loopImportsNext done' summarised - return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') - FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImportsNext done summarised - return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') - FoundHomeWithError (_uid, e) -> loopImportsNext done (Map.insert cache_key [(Left e)] summarised) - FoundHome s -> do - (done', summarised') <- - loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) - (other_deps, final_done, final_summarised) <- loopImportsNext done' summarised' - - -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) - where - loopImportsNext = loopImports home_uid ss - cache_key = (home_uid, mb_pkg, unLoc <$> gwib) - GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib - wanted_mod = L loc mod - -loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode -loopUnit _ cache [] = cache -loopUnit lcl_hsc_env cache (u:uxs) = do - let nk = (NodeKey_ExternalUnit u) - case Map.lookup nk cache of - Just {} -> loopUnit lcl_hsc_env cache uxs - Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of - Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs - Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) - -multiRootsErr :: SourceErrorContext -> [ModuleNodeInfo] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr sec summs@(summ1:_) + DownsweepEnv hsc_env mode summaries_cache_ref imports_cache_ref excl_mods <- ask + liftIO $ case mode of + DownsweepUseCompile -> + summariseModule hsc_env home_unit summaries_cache_ref imports_cache_ref + is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> + summariseModuleInterface hsc_env home_unit imports_cache_ref is_boot + wanted_mod mb_pkg excl_mods + +multiRootsErr :: SourceErrorContext -> NE.NonEmpty ModuleNodeInfo -> IO () +multiRootsErr sec (summ1 NE.:| summs) = throwOneError sec $ fmap GhcDriverMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files where mod = moduleNodeInfoModule summ1 - files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) (summ1:summs) moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) @@ -734,24 +773,25 @@ linkNodes summaries uid hue = getRootSummary :: [ModuleName] -> - M.Map (UnitId, OsPath) ModSummary -> + ModSummaryCache -> + ImportsCache -> HscEnv -> Target -> IO (Either DriverMessages ModSummary) -getRootSummary excl_mods old_summary_map hsc_env target +getRootSummary excl_mods summ_cache imports_cache hsc_env target | TargetFile file mb_phase <- targetId = do let offset_file = augmentByWorkingDirectory dflags file exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf - then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + then summariseFile hsc_env home_unit summ_cache offset_file mb_phase maybe_buf else return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do - maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot + maybe_summary <- summariseModule hsc_env home_unit summ_cache imports_cache NotBoot (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods pure case maybe_summary of @@ -1179,13 +1219,6 @@ Potential TODOS: generating temporary ones. -} --- | Populate the Downsweep cache with the root modules. -mkRootMap - :: [ModuleNodeInfo] - -> DownsweepCache -mkRootMap summaries = Map.fromListWith (flip (++)) - [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] - ----------------------------------------------------------------------------- -- Summarising modules @@ -1202,33 +1235,39 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, OsPath) ModSummary -- old summaries + -> ModSummaryCache -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) -> IO (Either DriverMessages ModSummary) -summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries - = do - let location = ms_location $ old_summary - - src_hash <- get_src_hash - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getFileHash may fail, but that's the right - -- behaviour. - - -- return the cached summary if the source didn't change - checkSummaryHash - hsc_env (new_summary src_fn) - old_summary location src_hash - - | otherwise - = do src_hash <- get_src_hash - new_summary src_fn src_hash +summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf + = do file_summ_cache <- readIORef summ_cache_ref + case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of + Just (Right (chd_summary, SummFresh)) -> + -- Fresh: use it straight away + pure (Right chd_summary) + Just (Right (old_summary, SummOld)) -> do + -- we can use a cached summary if one is available and the + -- source file hasn't changed, + let location = ms_location $ old_summary + + src_hash <- get_src_hash + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getFileHash may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + res <- checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash + case res of + Right ms -> modifySummCache summ_cache_ref (addModSummaryCache ms SummFresh) + Left _ -> pure () + return res + _ -> do src_hash <- get_src_hash + new_summary src_fn src_hash where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' @@ -1239,7 +1278,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf Just (buf,_) -> return $ fingerprintStringBuffer buf Nothing -> liftIO $ getFileHash src_fn - new_summary src_fn src_hash = runExceptT $ do + new_summary src_fn src_hash = do + res <- runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf @@ -1270,6 +1310,10 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf , nms_mod = mod , nms_preimps = preimps } + modifySummCache summ_cache_ref $ case res of + Left e -> M.insert (homeUnitId home_unit, src_fn_os) (Left e) + Right ms -> addModSummaryCache ms SummFresh + return res checkSummaryHash :: HscEnv @@ -1322,15 +1366,16 @@ data SummariseResult = -- --make mode. summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, OsPath) ModSummary + -> ModSummaryCache + -> ImportsCache -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO SummariseResult -summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = - summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods +summariseModule hsc_env home_unit old_summaries imps_cache is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env imps_cache home_unit is_boot wanted_mod mb_pkg excl_mods where k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf @@ -1339,13 +1384,14 @@ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_ -- This version always returns a ModuleNodeFixed node. summariseModuleInterface :: HscEnv -> HomeUnit + -> ImportsCache -> IsBootInterface -> Located ModuleName -> PkgQual -> [ModuleName] -> IO SummariseResult -summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = - summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods +summariseModuleInterface hsc_env home_unit imps_cache is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env imps_cache home_unit is_boot wanted_mod mb_pkg excl_mods where k _hsc_env loc mod = do -- The finder will return a path to the .hi-boot even if it doesn't actually @@ -1362,6 +1408,7 @@ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = summariseModuleDispatch :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. -> HscEnv + -> ImportsCache -> HomeUnit -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -1370,7 +1417,7 @@ summariseModuleDispatch -> IO SummariseResult -summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods +summariseModuleDispatch k hsc_env' imps_cache_ref home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods | wanted_mod `elem` excl_mods = return NotThere | otherwise = find_it @@ -1380,112 +1427,133 @@ summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg exc hsc_env = hscSetActiveHomeUnit home_unit hsc_env' find_it :: IO SummariseResult - find_it = do - found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg - case found of - Found location mod - | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> - -- Home package - k hsc_env location mod - | VirtUnit iud <- moduleUnit mod - , not (isHomeModule home_unit mod) - -> return $ FoundInstantiation iud - | otherwise -> return $ External (moduleUnitId mod) - _ -> return NotThere - -- Not found - -- (If it is TRULY not found at all, we'll - -- error when we actually try to compile) - + imps_cache <- readIORef imps_cache_ref + case M.lookup cache_key imps_cache of + Just result -> return result + Nothing -> do + found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg + r <- case found of + Found location mod + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> + -- Home package + k hsc_env location mod + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> return $ FoundInstantiation iud + | otherwise -> return $ External (moduleUnitId mod) + _ -> return NotThere + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + modifyImpsCache imps_cache_ref (M.insert cache_key r) + return r + + cache_key = ( homeUnitId home_unit, mb_pkg + , GWIB{ gwib_mod = wanted_mod, gwib_isBoot = is_boot }) -- | The continuation to summarise a home module if we want to find the source file -- for it and potentially compile it. summariseModuleWithSource :: HomeUnit - -> M.Map (UnitId, OsPath) ModSummary - -- ^ Map of old summaries + -> ModSummaryCache + -- ^ Cache of constructed summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Maybe (StringBuffer, UTCTime) -> HscEnv -> ModLocation -> Module -> IO SummariseResult -summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let src_fn = expectJust (ml_hs_file location) - - -- Check that it exists - -- It might have been deleted since the Finder last found it +summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let src_fn = expectJust (ml_hs_file location) + summ_cache <- readIORef summ_cache_ref + case ml_hs_file_ospath location >>= \p -> M.lookup (moduleUnitId mod, p) summ_cache of + Just (Right (chd_summary, SummFresh)) -> + -- Fresh! just return it + pure $ FoundHome (ModuleNodeCompile chd_summary) + + Just (Left err) -> + -- Failure, don't try to summarise it again + pure $ FoundHomeWithError (moduleUnitId mod, err) + + mb_old -> do + -- Either Nothing or a potentially old summary, must check. + + -- Check that it exists + -- It might have been deleted since the Finder last found it maybe_h <- fileHashIfExists src_fn case maybe_h of -- This situation can also happen if we have found the .hs file but the -- .hs-boot file doesn't exist. Nothing -> return NotThere Just h -> do - fresult <- new_summary_cache_check location mod src_fn h + fresult <- case mb_old of + Just (Right (old_summary, SummOld)) -> + -- check the hash on the source file, and return the cached + -- summary if it hasn't changed. If the file has changed then + -- need to resummarise. + case maybe_buf of + Just (buf,_) -> + checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location (fingerprintStringBuffer buf) + Nothing -> + checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location h + Nothing -> + new_summary location mod src_fn h return $ case fresult of Left err -> FoundHomeWithError (moduleUnitId mod, err) Right ms -> FoundHome (ModuleNodeCompile ms) - where dflags = hsc_dflags hsc_env - new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = - - -- check the hash on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has changed then need to resummarise. - case maybe_buf of - Just (buf,_) -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) - Nothing -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h - | otherwise = new_summary loc mod src_fn h - where - src_fn_os = unsafeEncodeUtf src_fn - new_summary :: ModLocation -> Module -> FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary) new_summary location mod src_fn src_hash - = runExceptT $ do - preimps@PreprocessedImports {..} - -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP - -- See multiHomeUnits_cpp2 test - <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf - - -- NB: Despite the fact that is_boot is a top-level parameter, we - -- don't actually know coming into this function what the HscSource - -- of the module in question is. This is because we may be processing - -- this module because another module in the graph imported it: in this - -- case, we know if it's a boot or not because of the {-# SOURCE #-} - -- annotation, but we don't know if it's a signature or a regular - -- module until we actually look it up on the filesystem. - let hsc_src - | is_boot == IsBoot = HsBootFile - | isHaskellSigFilename src_fn = HsigFile - | otherwise = HsSrcFile - - when (pi_mod_name /= moduleName mod) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) - - let instantiations = homeUnitInstantiations home_unit - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations - - liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary - { nms_src_fn = src_fn - , nms_src_hash = src_hash - , nms_hsc_src = hsc_src - , nms_location = location - , nms_mod = mod - , nms_preimps = preimps - } + = do + res <- runExceptT $ do + preimps@PreprocessedImports {..} + -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP + -- See multiHomeUnits_cpp2 test + <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src + | is_boot == IsBoot = HsBootFile + | isHaskellSigFilename src_fn = HsigFile + | otherwise = HsSrcFile + + when (pi_mod_name /= moduleName mod) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) + + let instantiations = homeUnitInstantiations home_unit + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + modifySummCache summ_cache_ref $ case res of + Left e -> case ml_hs_file_ospath location of + Just p -> M.insert (moduleUnitId mod, p) (Left e) + Nothing -> id + Right ms -> addModSummaryCache ms SummFresh + return res -- | Convenience named arguments for 'makeNewModSummary' only used to make -- code more readable, not exported. @@ -1568,3 +1636,89 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let pi_srcimps = pi_srcimps' let pi_theimps = rn_imps pi_theimps' return PreprocessedImports {..} + +-------------------------------------------------------------------------------- + +-- | In a depth-first order, and starting from the given roots, traverse a +-- graph by iteratively expanding a node into a payload and a list of children +-- nodes to visit next. +-- +-- A node is NEVER visited/expanded more than once, as long as the the +-- node key @k@, computed from the node @n@, uniquely identifies that node. +-- +-- The first argument @base_map@ is the starting set of already visited nodes +-- (these nodes won't be expanded again!). +-- +-- The result is a mapping from the key of every node transitively reachable +-- from the root nodes (inclusively) to the payload returned by expanding that +-- node. The result includes the previously visited nodes given in @base_map@, +-- s.t. @dfsBuild base_map [] _ _ == base_map@. +-- +-- The @expand@ function may return 'Nothing' if it couldn't compute a payload +-- and/or children value for the given node. This makes 'dfsBuild' ignore that +-- node and continue without failure. We do not cache a "negative" result for +-- the 'Nothing', because we may yet discover new information (in the monadic +-- context) and try to expand that node in the future again, then successfully. +-- +-- Error handling and exiting early can be achieved by selecting a @Monad m@ +-- accordingly, such as @Control.Monad.Except.Except@ +-- +-- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@. +-- +-- See also Note [Downsweep Control Flow and Caching] +dfsBuild :: (Ord k, Monad m) => Maybe (Map.Map k v) -> [n] -> (n -> k) -> (n -> m (Maybe (v,[n]))) -> m (Map.Map k v) +dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) + where + go [] visited = pure visited + go (s:ss) visited + | k `Map.member` visited + = go ss visited + | otherwise + = do r <- expand s + case r of + Nothing -> go ss visited -- Skip! + Just (v,ns) -> + go (ns ++ ss {- todo: not use ++ here? -}) + (Map.insert k v visited) + where + k = key s + +{- +Note [Downsweep Control Flow and Caching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The control flow of downsweep is extracted into a single function `dfsBuild`, +which takes care of iteratively expanding and traversing all nodes of the +in-construction module graph necessary to build a full `ModuleGraph` at the +end. + +There are three levels of caching going on, all of which are necessary to make +sure we don't do repeated work (notably, we NEVER summarise the same module +twice). + +1. `dfsBuild` accumulates the final module graph and never revisits the + same node of the module graph. Cache is keyed by the final + `ModuleGraph`s `NodeKey`s. + +2. For Module A in home-unit u1, each import in the list of imports + needs to be *found* (call to `findImportedModuleWithIsBoot`): at this + point, we only have the `ModuleName` of the import, not the `Module`. + This *finding* is somewhat expensive, so we cache it as well + (`ImportsCache`). The cache key is the home-unit to which the module + belongs~[1], the import package qualifier, and the ModuleName. + + [1] Different home-units will have different package flags, which means + potentially different `Module` resolution for the same `ModuleName`. + +3. The most expensive operation we want to avoid is summarising a + `Module` into a `ModSummary`, which notably involves parsing the + module header from scratch. + The third cache, in essence, maps a `Module` to its `ModSummary` + (named `ModSummaryCache`). This cache upholds the invariant: we NEVER + summarise the same module twice. In practice, the cache key is the + Module's UnitId and the Source path; the reason is we need to + distinguish between `.hs` and `.hs-boot` files, as their summaries + will differ. + + Note that (2) can't guarantee this alone: Two ModuleName imports in + separate units can (and likely do) map to the same `Module`. +-} ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -24,6 +24,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Driver.MakeFile import GHC.Utils.Outputable +import Data.IORef (newIORef) -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = @@ -151,5 +152,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -16,6 +16,7 @@ import GHC.Types.SourceFile import System.Environment import Control.Monad (void, when) import Data.Maybe (fromJust) +import Data.IORef (newIORef) import Control.Exception (ExceptionWithContext(..), SomeException) import Control.Monad.Catch (handle, throwM) import Control.Exception.Context @@ -67,7 +68,9 @@ main = do keyC = msKey msC let mkGraph s = do - ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s [] + summ_cache <- newIORef mempty + imps_cache <- newIORef mempty + ([], nodes) <- downsweepFromRootNodes hsc_env summ_cache imps_cache Nothing [] True DownsweepUseFixed s [] return $ mkModuleGraph nodes graph <- liftIO $ mkGraph [ModuleNodeCompile msC] @@ -98,5 +101,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -23,6 +23,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Utils.Outputable import Data.List +import Data.IORef (newIORef) -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo @@ -132,5 +133,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/splice-imports/SI35.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Stage import GHC.Data.Graph.Directed.Reachability import GHC.Utils.Trace import GHC.Unit.Module.Graph +import Data.IORef (newIORef) main :: IO () main = do @@ -75,5 +76,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms \ No newline at end of file ===================================== utils/check-ppr/Main.hs ===================================== @@ -18,6 +18,7 @@ import System.Environment( getArgs ) import System.Exit import System.FilePath import System.IO +import Data.IORef usage :: String usage = unlines @@ -85,7 +86,8 @@ parseOneFile libdir fileName = do let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) mempty fileName Nothing Nothing + cache <- liftIO $ newIORef mempty + mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) cache fileName Nothing Nothing case mms of Left _err -> error "parseOneFile" Right ms -> parseModule ms View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eb79ca6a8bcb3316ead8b2fd0cab39… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eb79ca6a8bcb3316ead8b2fd0cab39… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/fix-unreg
by Cheng Shao (＠TerrorJack) 13 Jul '26

13 Jul '26

Cheng Shao deleted branch wip/fix-unreg at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/fix-layout-stack-fcall
by Cheng Shao (＠TerrorJack) 13 Jul '26

13 Jul '26

Cheng Shao deleted branch wip/fix-layout-stack-fcall at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0