July 2026 - ghc-commits

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

14 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1718230f by Alan Zimmerman at 2026-07-14T18:01:06-04: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 - - - - - 25 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 - 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 ===================================== 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/-/commit/1718230f4d3d19d8c49c0e5d496cb0f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1718230f4d3d19d8c49c0e5d496cb0f… 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][master] compiler: fix miscompiled %load_relaxed, add missing %store_relaxed
by Marge Bot (＠marge-bot) 14 Jul '26

14 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: eee8ec5b by Cheng Shao at 2026-07-14T18:00:20-04:00 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> - - - - - 4 changed files: - + changelog.d/fix-cmm-atomic-load-store - compiler/GHC/Cmm/Parser.y - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm Changes: ===================================== changelog.d/fix-cmm-atomic-load-store ===================================== @@ -0,0 +1,4 @@ +section: cmm +synopsis: Fix miscompiled %load_relaxed primop, add missing %store_relaxed +issues: #27483 +mrs: !16320 ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -1210,9 +1210,10 @@ callishMachOps platform = listToUFM $ , allWidths "pext" MO_Pext , allWidths "cmpxchg" MO_Cmpxchg , allWidths "xchg" MO_Xchg - , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderRelaxed) , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire) , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) + , allWidths "store_relaxed" (\w -> MO_AtomicWrite w MemOrderRelaxed) , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add) ===================================== testsuite/tests/cmm/should_run/AtomicFetch.hs ===================================== @@ -6,6 +6,7 @@ -- This is not a test of atomic semantics, -- just checking that GHC can parse %fetch_fooXX +-- and %load/%store with explicit ordering import GHC.Exts import GHC.Int ===================================== testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm ===================================== @@ -2,6 +2,7 @@ // This is not a test of atomic semantics, // just checking that GHC can parse %fetch_fooXX +// and %load/%store with explicit ordering cmm_foo64 (P_ p) { @@ -19,6 +20,10 @@ cmm_foo64 (P_ p) (x) = prim %fetch_xor64(q, 33 :: I64); (x) = prim %fetch_nand64(q, 127 :: I64); (x) = prim %load_seqcst64(q); + prim %store_relaxed64(q, x); + (x) = prim %load_relaxed64(q); + prim %store_release64(q, x); + (x) = prim %load_acquire64(q); return (x); } @@ -38,6 +43,10 @@ cmm_foo32 (P_ p) (x) = prim %fetch_xor32(q, 33 :: I32); (x) = prim %fetch_nand32(q, 127 :: I32); (x) = prim %load_seqcst32(q); + prim %store_relaxed32(q, x); + (x) = prim %load_relaxed32(q); + prim %store_release32(q, x); + (x) = prim %load_acquire32(q); return (x); } @@ -57,6 +66,10 @@ cmm_foo16 (P_ p) (x) = prim %fetch_xor16(q, 33 :: I16); (x) = prim %fetch_nand16(q, 127 :: I16); (x) = prim %load_seqcst16(q); + prim %store_relaxed16(q, x); + (x) = prim %load_relaxed16(q); + prim %store_release16(q, x); + (x) = prim %load_acquire16(q); return (x); } @@ -76,5 +89,9 @@ cmm_foo8 (P_ p) (x) = prim %fetch_xor8(q, 33 :: I8); (x) = prim %fetch_nand8(q, 127 :: I8); (x) = prim %load_seqcst8(q); + prim %store_relaxed8(q, x); + (x) = prim %load_relaxed8(q); + prim %store_release8(q, x); + (x) = prim %load_acquire8(q); return (x); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee8ec5b25ef0f83ba4822e7a0a941d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee8ec5b25ef0f83ba4822e7a0a941d… 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][master] hadrian: fix HLS support
by Marge Bot (＠marge-bot) 14 Jul '26

14 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ed261a7e by Cheng Shao at 2026-07-14T17:59:38-04:00 hadrian: fix HLS support This patch fixes hadrian's HLS support so one can rely on HLS when working on the hadrian codebase. Fixes #27480. Not building/linking shared libraries for hadrian is a severely premature optimization; this top-level setting in `cabal.project` only affects home packages while the dependencies in the cabal store are built with vanilla/dynamic anyway, and even adding dynamic builds to home packages would not be costly due to cabal's usage of `-dynamic-too`. - - - - - 1 changed file: - hadrian/cabal.project Changes: ===================================== hadrian/cabal.project ===================================== @@ -12,7 +12,3 @@ index-state: 2026-03-10T17:36:36Z -- and the Cabal takes nearly twice as long to build with -O1. See #16817. package Cabal optimization: False - --- Build static linked, vanilla libraries to reduce build time. -shared: False -executable-dynamic: False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed261a7eef3e8e785c83b71c44fdaf3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed261a7eef3e8e785c83b71c44fdaf3… 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] Trailing whitespace
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: 287b8a8c by GHC GitLab CI at 2026-07-14T22:12:40+02:00 Trailing whitespace - - - - - 1 changed file: - .gitlab/generate-ci/gen_ci.hs Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -962,7 +962,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } , artifactPaths = [binDistName arch opsys buildConfig ++ ".tar.xz" ,"junit.xml" ,"unexpected-test-output.tar.gz"] - ++ stage3Artifacts + ++ stage3Artifacts , artifactsWhen = ArtifactsAlways } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/287b8a8c88a88036b20ea2e548273c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/287b8a8c88a88036b20ea2e548273c8… 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] Better comment
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: af2e4a23 by GHC GitLab CI at 2026-07-14T22:09:20+02:00 Better comment - - - - - 1 changed file: - hadrian/src/Rules/Generate.hs Changes: ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -483,14 +483,11 @@ bindistRules = do , 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. + -- We can build two kinds of bindists: Regular Stage2 (including + -- cross-compilers) and fully cross-compiled Stage3. To avoid + -- race-conditions, stale files, etc. build the `configure` scripts as part + -- of the stage's _build files. This requires copying several files such that + -- they are available to the autoconf run. forM_ [Stage1, Stage2] $ \stage -> do let distribDir = root -/- stageString stage -/- "distrib" @@ -498,9 +495,6 @@ bindistRules = 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af2e4a23fdc0673c53cea816ec34321… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af2e4a23fdc0673c53cea816ec34321… 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: Final cleanup
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: 936a89cc by GHC GitLab CI at 2026-07-14T20:50:46+02:00 Final cleanup - - - - - 8579bf77 by GHC GitLab CI at 2026-07-14T21:15:56+02:00 Simplify ci.sh - - - - - 5868b371 by GHC GitLab CI at 2026-07-14T21:43:07+02:00 Add stage3 check to ci.sh - - - - - 7adbf51f by GHC GitLab CI at 2026-07-14T21:46:42+02:00 Revert unnecessary change - - - - - 0defb0c6 by GHC GitLab CI at 2026-07-14T21:47:30+02:00 Update jobs.yaml - - - - - dd57c677 by GHC GitLab CI at 2026-07-14T21:47:37+02:00 Typo - - - - - 73859934 by GHC GitLab CI at 2026-07-14T21:48:12+02:00 Cleanup diff - - - - - 6 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - hadrian/src/BindistConfig.hs - hadrian/src/Rules/CabalReinstall.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -575,8 +575,14 @@ function build_hadrian() { case "${CROSS_STAGE:-2}" in 2) BINDIST_TARGET="binary-dist";; # Stage2 cross-compiler bindists are (almost) a byproduct of Stage3 - # cross-compiled bindists. So, we bundle both of them - 3) BINDIST_TARGET="binary-dist binary-dist-stage3";; + # cross-compiled bindists. So, we bundle both of them when the Stage3 + # bindist is built. + 3) + BINDIST_TARGET="binary-dist binary-dist-stage3" + if [[ -z "${BIN_DIST_NAME_STAGE3:-}" ]]; then + fail "CROSS_STAGE=3 requires BIN_DIST_NAME_STAGE3 to be set" + fi + ;; *) fail "Unknown CROSS_STAGE, must be 2 or 3";; esac @@ -592,9 +598,6 @@ function build_hadrian() { run_hadrian test:all_deps $BINDIST_TARGET mv _build/bindist/ghc*.tar.xz "$BIN_DIST_NAME.tar.xz" if [[ "${CROSS_STAGE:-2}" == "3" ]]; then - if [[ -z "${BIN_DIST_NAME_STAGE3:-}" ]]; then - fail "CROSS_STAGE=3 requires BIN_DIST_NAME_STAGE3 to be set" - fi mv _build/bindist-stage3/ghc*.tar.xz "$BIN_DIST_NAME_STAGE3.tar.xz" fi ;; @@ -682,11 +685,6 @@ function test_hadrian() { # If we have set CROSS_EMULATOR, then can't test using normal testsuite. elif [ -n "${CROSS_EMULATOR:-}" ] && [[ "${CROSS_TARGET:-}" != *"wasm"* ]]; then local instdir="$TOP/_build/install" - # The stage-2 cross bindist has target-triple-prefixed binaries and runs - # natively on the host. Override the global cross_prefix (which is empty - # for CROSS_STAGE=3 because the stage-3 bindist has unprefixed binaries) - # so that we test the stage-2 cross compiler consistently. - local cross_prefix="$target_triple-" local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" install_bindist _build/bindist/ghc-*/ "$instdir" echo 'main = putStrLn "hello world"' > expected @@ -708,6 +706,26 @@ function test_hadrian() { # --- # > main = putStrLn "hello world" run diff -w expected actual + + if [[ "${CROSS_STAGE:-2}" == "3" ]]; then + local stage3_dir + stage3_dir="$(echo _build/bindist-stage3/ghc-*/)" + local stage3_ghc="$stage3_dir/bin/ghc$exe" + + info "Smoke-testing stage3 compiler..." + file "$stage3_ghc" + run ${CROSS_EMULATOR} "$stage3_ghc" --info + + run ${CROSS_EMULATOR} "$stage3_ghc" -package ghc "$TOP/.gitlab/hello.hs" -o hello-stage3 + + if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then + ${CROSS_EMULATOR:-} ./hello-stage3.exe > actual-stage3 + else + ${CROSS_EMULATOR:-} ./hello-stage3 > actual-stage3 + fi + + run diff -w expected actual-stage3 + fi elif [[ -n "${REINSTALL_GHC:-}" ]]; then run_hadrian \ test \ @@ -935,8 +953,7 @@ function clean() { # # The exclude list are the artifacts that we do expect to be # uploaded. Keep in sync with `jobArtifacts` in - # `.gitlab/generate-ci/gen_ci.hs`! The `ghc-*.tar.xz` pattern covers both - # stage2/cross and stage3/target bindists. + # `.gitlab/generate-ci/gen_ci.hs`! if [[ "${CI_DISPOSABLE_ENVIRONMENT:-}" != true ]]; then git submodule --quiet foreach --recursive git clean -xdfq git clean -xdfq \ @@ -1046,15 +1063,12 @@ case "$(uname)" in *) fail "uname $(uname) is not supported" ;; esac -cross_prefix="" if [ -n "${CROSS_TARGET:-}" ]; then - info "Cross-compiling for $CROSS_TARGET... (stage: $CROSS_STAGE)" + info "Cross-compiling for $CROSS_TARGET..." target_triple="$CROSS_TARGET" - # Stage3 native GHC runs on the target itself, so no cross prefix. - # CROSS_STAGE is either 2 (host != target) or 3 (host == target) - if [ "${CROSS_STAGE:-2}" = "2" ]; then - cross_prefix="$target_triple-" - fi + cross_prefix="$target_triple-" +else + cross_prefix="" fi echo "Branch name ${CI_MERGE_REQUEST_SOURCE_BRANCH_NAME:-}" ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -159,7 +159,7 @@ data BuildConfig , withNuma :: Bool , withZstd :: Bool , crossTarget :: Maybe String - , crossStage :: Maybe Int + , crossStage :: Maybe FinalCrossStage , crossEmulator :: CrossEmulator , configureWrapper :: Maybe String , fullyStatic :: Bool @@ -275,14 +275,26 @@ static = vanilla { fullyStatic = True } staticNativeInt :: BuildConfig staticNativeInt = static { bignumBackend = Native } --- | cross-compiler (build == host, host /= target) -stage2CrossConfig :: String -- ^ target triple +-- | The final stage for which binary distrubutions should be built +-- +-- `Stage2` builds a cross-compiler (build == host, host /= target). `Stage3` +-- implies `Stage2` and additionally builds a cross-compiled compiler (build /= +-- host, host == target). +data FinalCrossStage = Stage2 | Stage3 + deriving (Eq, Ord) + +crossStageToInt :: FinalCrossStage -> Int +crossStageToInt Stage2 = 2 +crossStageToInt Stage3 = 3 + +crossConfig :: String -- ^ target triple -> CrossEmulator -- ^ emulator for testing -> Maybe String -- ^ Configure wrapper + -> FinalCrossStage -- ^ final stage to build -> BuildConfig -stage2CrossConfig triple emulator configure_wrapper = +crossConfig triple emulator configure_wrapper crossStage = vanilla { crossTarget = Just triple - , crossStage = Just 2 + , crossStage = Just crossStage , crossEmulator = emulator , configureWrapper = configure_wrapper } @@ -895,7 +907,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } [ opsysVariables arch opsys , "TEST_ENV" =: testEnv arch opsys buildConfig , "BIN_DIST_NAME" =: binDistName arch opsys buildConfig - , if crossStage buildConfig == Just 3 + , if crossStage buildConfig == Just Stage3 then "BIN_DIST_NAME_STAGE3" =: binDistNameStage3 arch opsys buildConfig else mempty , "BUILD_FLAVOUR" =: flavourString jobFlavour @@ -904,7 +916,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } , "INSTALL_CONFIGURE_ARGS" =: "--enable-strict-ghc-toolchain-check" , maybe mempty ("CONFIGURE_WRAPPER" =:) (configureWrapper buildConfig) , maybe mempty ("CROSS_TARGET" =:) (crossTarget buildConfig) - , maybe mempty (("CROSS_STAGE" =:) . show) (crossStage buildConfig) + , maybe mempty (("CROSS_STAGE" =:) . show . crossStageToInt) (crossStage buildConfig) , case crossEmulator buildConfig of NoEmulator -- we need an emulator but it isn't set. Won't run the testsuite @@ -938,8 +950,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } trim = dropWhileEnd isSpace . dropWhile isSpace stage3Artifacts - | crossStage buildConfig == Just 3 - = [binDistNameStage3 arch opsys buildConfig ++ ".tar.xz"] + | crossStage buildConfig == Just Stage3 = + [binDistNameStage3 arch opsys buildConfig ++ ".tar.xz"] | otherwise = [] -- Keep in sync with the exclude list in `function clean()` in @@ -947,9 +959,10 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } jobArtifacts = Artifacts { junitReport = "junit.xml" , expireIn = "2 weeks" - , artifactPaths = stage3Artifacts ++ [binDistName arch opsys buildConfig ++ ".tar.xz" + , artifactPaths = [binDistName arch opsys buildConfig ++ ".tar.xz" ,"junit.xml" ,"unexpected-test-output.tar.gz"] + ++ stage3Artifacts , artifactsWhen = ArtifactsAlways } @@ -1308,13 +1321,13 @@ alpine_aarch64 = [ cross_jobs :: [JobGroup Job] cross_jobs = [ -- x86 -> aarch64 - validateBuilds Amd64 (Linux Debian13) (stage2CrossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) + validateBuilds Amd64 (Linux Debian13) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing Stage2) -- x86_64 (build) -> riscv64 (host/target) - , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian13Riscv) (stage2CrossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing) { crossStage = Just 3 }) + , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian13Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing Stage3)) -- x86_64 -> loongarch64 - , addValidateRule LoongArch64 (validateBuilds Amd64 (Linux Ubuntu2404LoongArch64) (stage2CrossConfig "loongarch64-linux-gnu" (Emulator "qemu-loongarch64 -L /usr/loongarch64-linux-gnu") Nothing)) + , addValidateRule LoongArch64 (validateBuilds Amd64 (Linux Ubuntu2404LoongArch64) (crossConfig "loongarch64-linux-gnu" (Emulator "qemu-loongarch64 -L /usr/loongarch64-linux-gnu") Nothing Stage2)) -- Javascript , addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11Js) javascriptConfig) @@ -1335,7 +1348,7 @@ cross_jobs = [ (validateBuilds AArch64 (Linux Debian12Wine) (winAarch64Config {llvmBootstrap = True})) ] where - javascriptConfig = (stage2CrossConfig "javascript-unknown-ghcjs" (NoEmulatorNeeded TimeoutIncrease) (Just "emconfigure")) + javascriptConfig = (crossConfig "javascript-unknown-ghcjs" (NoEmulatorNeeded TimeoutIncrease) (Just "emconfigure") Stage2) { bignumBackend = Native } makeWinArmJobs = modifyJobs @@ -1374,7 +1387,7 @@ cross_jobs = [ llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-" cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt" - winAarch64Config = (stage2CrossConfig "aarch64-unknown-mingw32" (Emulator "/opt/wine-arm64ec-msys2-deb12/bin/wine") Nothing) + winAarch64Config = (crossConfig "aarch64-unknown-mingw32" (Emulator "/opt/wine-arm64ec-msys2-deb12/bin/wine") Nothing Stage2) { bignumBackend = Native } make_wasm_jobs cfg = @@ -1387,7 +1400,7 @@ cross_jobs = [ $ addValidateRule WasmBackend $ validateBuilds Amd64 (Linux AlpineWasm) cfg wasm_build_config = - (stage2CrossConfig "wasm32-wasi" (NoEmulatorNeeded NoTimeoutIncrease) Nothing) + (crossConfig "wasm32-wasi" (NoEmulatorNeeded NoTimeoutIncrease) Nothing Stage2) { hostFullyStatic = True , buildFlavour = Release -- TODO: This needs to be validate but wasm backend doesn't pass yet , textWithSIMDUTF = True @@ -1458,9 +1471,8 @@ platform_mapping = Map.map go combined_result process sel = Map.fromListWith combine - [ (mkPlatform a o, j) + [ (uncurry mkPlatform (jobPlatform (jobInfo j)), j) | (sel -> Just j) <- job_groups - , let (a, o) = jobPlatform (jobInfo j) ] vs = process v ===================================== .gitlab/jobs.yaml ===================================== @@ -2748,10 +2748,10 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz", "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate.tar.xz", "junit.xml", - "unexpected-test-output.tar.gz" + "unexpected-test-output.tar.gz", + "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz" ], "reports": { "junit": "junit.xml" @@ -6726,10 +6726,10 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz", "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate.tar.xz", "junit.xml", - "unexpected-test-output.tar.gz" + "unexpected-test-output.tar.gz", + "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz" ], "reports": { "junit": "junit.xml" ===================================== hadrian/src/BindistConfig.hs ===================================== @@ -3,11 +3,11 @@ 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 } - -- | A bindist for when the host = target, non cross-compilation setting. -- Both the libraries and final executables are built with stage1 compiler. normalBindist :: BindistConfig ===================================== hadrian/src/Rules/CabalReinstall.hs ===================================== @@ -67,14 +67,13 @@ cabalBuildRules = do let cabal_package_db = cwd -/- root -/- "stage-cabal" -/- "dist-newstyle" -/- "packagedb" -/- "ghc-" ++ version - executableStage <- executable_stage <$> implicitBindistConfig forM_ bin_targets $ \(bin_pkg,_bin_path) -> do let pgmName pkg | pkg == ghc = "ghc" | pkg == hpcBin = "hpc" | otherwise = pkgName pkg let cabal_bin_out = work_dir -/- "cabal-bin" -/- (pgmName bin_pkg) - needed_wrappers <- pkgToWrappers executableStage bin_pkg + needed_wrappers <- pkgToWrappers Stage2 bin_pkg forM_ needed_wrappers $ \wrapper_name -> do let wrapper_prefix = unlines ["#!/usr/bin/env sh" @@ -86,7 +85,7 @@ cabalBuildRules = do ,"export GHC_PACKAGE_PATH="++show cabal_package_db++":" ] output_file = outputDir -/- wrapper_name - wrapper_content <- wrapper executableStage wrapper_name + wrapper_content <- wrapper Stage2 wrapper_name writeFile' output_file (wrapper_prefix ++ wrapper_content) makeExecutable output_file pure () ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -423,7 +423,7 @@ bindistRules = do , interpolateVar "HostOS_CPP" $ fmap cppify $ interp $ queryHost queryOS - -- Stage2 always targets the final architecture. Thus, we can use a + -- 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4713cc0b013178d84d544ad6b985f9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4713cc0b013178d84d544ad6b985f9… 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] Add tests
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: ead5f6b1 by Wolfgang Jeltsch at 2026-07-14T21:26:49+03:00 Add tests - - - - - 6 changed files: - + testsuite/tests/show-bytecode/Example.hs - + testsuite/tests/show-bytecode/Makefile - + testsuite/tests/show-bytecode/all.T - + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout - + testsuite/tests/show-bytecode/show-bytecode-hpc.stdout - + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout Changes: ===================================== testsuite/tests/show-bytecode/Example.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE StaticPointers #-} + +module Example where + +import Numeric.Natural (Natural) +import GHC.StaticPtr (StaticPtr) + +fibonaccis :: [Natural] +fibonaccis = 0 : positiveFibonaccis where + + positiveFibonaccis :: [Natural] + positiveFibonaccis = 1 : zipWith (+) fibonaccis positiveFibonaccis + +fibonaccisPtr :: StaticPtr [Natural] +fibonaccisPtr = static fibonaccis + +divides :: Integral a => a -> a -> Bool +k `divides` n = n `mod` k == 0 + +primes :: [Natural] +primes = 2 : filter isPrime [3 ..] where + + isPrime :: Natural -> Bool + isPrime n = not (any (`divides` n) (takeWhile ((<= n) . (^ 2)) primes)) + +primesPtr :: StaticPtr [Natural] +primesPtr = static primes + +data BinTree a b = Leaf a | Node (BinTree a b) b (BinTree a b) + +data PerfectTree a = PerfectTree a | Nested (PerfectTree (a, a)) ===================================== testsuite/tests/show-bytecode/Makefile ===================================== @@ -0,0 +1,19 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +compile = '$(TEST_HC)' $(TEST_HC_OPTS) -fbyte-code -fwrite-byte-code -no-link +show = '$(TEST_HC)' $(TEST_HC_OPTS) --show-byte-code +normalize = sed -E -e 's/_[[:alnum:]]+//g' + +show-bytecode-vanilla: + $(compile) Example.hs + $(show) Example.gbc | $(normalize) + +show-bytecode-breakpoints: + $(compile) -fbreak-points Example.hs + $(show) Example.gbc | $(normalize) + +show-bytecode-hpc: + $(compile) -fhpc Example.hs + $(show) Example.gbc | $(normalize) ===================================== testsuite/tests/show-bytecode/all.T ===================================== @@ -0,0 +1,18 @@ +test( + 'show-bytecode-vanilla', + extra_files(['Example.hs']), + makefile_test, + [] +) +test( + 'show-bytecode-breakpoints', + extra_files(['Example.hs']), + makefile_test, + [] +) +test( + 'show-bytecode-hpc', + extra_files(['Example.hs']), + makefile_test, + [] +) ===================================== testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout ===================================== @@ -0,0 +1,828 @@ +[1 of 1] Compiling Example ( Example.hs, Example.gbc ) +name: Example +hash: 35e1280518690981ffc1dfa3d7c3c18e +objects: + ordinary object ‘primesPtr’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 0 + utilized items: + break array of module ‘Example’ + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 2391484856205448807 + word 14295153105712797526 + utilized items: + item named ‘static’ + item named ‘primes’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 27 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 20 + utilized items: <none> + ordinary object ‘primes’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 2 + info table of ‘:’ + utilized items: + break array of module ‘Example’ + ordinary object ‘primes’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 1 + utilized items: + break array of module ‘Example’ + ordinary object ‘primes’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘primes’: + arity: 0 + literals: + word 3 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + item named ‘$fEnumNatural’ + item named ‘enumFrom’ + item named ‘isPrime’ + item named ‘filter’ + ordinary object ‘primes’: + arity: 0 + literals: + word 2 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 9 + utilized items: + break array of module ‘Example’ + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 8 + utilized items: + break array of module ‘Example’ + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 7 + utilized items: + break array of module ‘Example’ + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 6 + utilized items: + break array of module ‘Example’ + ordinary object ‘isPrime’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 5 + word 2 + info table of ‘IS’ + utilized items: + break array of module ‘Example’ + ordinary object ‘v’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fIntegralInteger’ + item named ‘$fNumNatural’ + item named ‘^’ + ordinary object ‘pap’: + arity: 3 + literals: <none> + utilized items: <none> + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 4 + utilized items: + break array of module ‘Example’ + ordinary object ‘v’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fOrdNatural’ + item named ‘<=’ + ordinary object ‘pap’: + arity: 3 + literals: <none> + utilized items: <none> + item named ‘.’ + item named ‘primes’ + item named ‘takeWhile’ + ordinary object ‘isPrime’: + arity: 1 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 3 + utilized items: + break array of module ‘Example’ + ordinary object ‘pap’: + arity: 2 + literals: <none> + utilized items: + item named ‘$fIntegralNatural’ + item named ‘divides’ + item named ‘$fFoldableList’ + item named ‘any’ + item named ‘not’ + ordinary object ‘fibonaccisPtr’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 10 + utilized items: + break array of module ‘Example’ + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 17112019464237448244 + word 14704510317759369968 + utilized items: + item named ‘static’ + item named ‘fibonaccis’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 15 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 24 + utilized items: <none> + ordinary object ‘fibonaccis’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 11 + info table of ‘:’ + utilized items: + break array of module ‘Example’ + ordinary object ‘fibonaccis’: + arity: 0 + literals: + word 0 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + item named ‘positiveFibonaccis’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 13 + info table of ‘:’ + utilized items: + break array of module ‘Example’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 12 + utilized items: + break array of module ‘Example’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fNumNatural’ + item named ‘+’ + item named ‘positiveFibonaccis’ + item named ‘fibonaccis’ + item named ‘zipWith’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: + word 1 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + ordinary object ‘$dTypeable2’: + arity: 0 + literals: <none> + utilized items: + item named ‘$dTypeable’ + item named ‘$dTypeable1’ + item named ‘mkTrAppChecked’ + ordinary object ‘$dTypeable1’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcList’ + item named ‘mkTrCon’ + ordinary object ‘$dTypeable’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcNatural’ + item named ‘mkTrCon’ + static-construction object ‘$tc'Nested’: + data constructor name: TyCon + lifted: yes + literals: + word 4886352401159288042 + word 15486177717927261000 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Nested2’ + item named ‘$krep17’ + static-construction object ‘$tc'Nested2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Nested1’ + utilized items: <none> + static-construction object ‘$krep17’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep16’ + item named ‘$krep13’ + static-construction object ‘$krep16’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep15’ + static-construction object ‘$krep15’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep4’ + item named ‘[]’ + static-construction object ‘$tc'PerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 1216274636751977258 + word 143956009589726941 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'PerfectTree2’ + item named ‘$krep14’ + static-construction object ‘$tc'PerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'PerfectTree1’ + utilized items: <none> + static-construction object ‘$krep14’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep13’ + static-construction object ‘$krep13’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep12’ + static-construction object ‘$krep12’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$tcPerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 11330648440307610868 + word 17396431681782259314 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcPerfectTree2’ + item named ‘krep$*Arr*’ + static-construction object ‘$tcPerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcPerfectTree1’ + utilized items: <none> + static-construction object ‘$tc'Node’: + data constructor name: TyCon + lifted: yes + literals: + word 2884468726215238492 + word 558166382591591938 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Node2’ + item named ‘$krep11’ + static-construction object ‘$tc'Node2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Node1’ + utilized items: <none> + static-construction object ‘$krep11’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep10’ + static-construction object ‘$krep10’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘$krep9’ + static-construction object ‘$krep9’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep7’ + static-construction object ‘$tc'Leaf’: + data constructor name: TyCon + lifted: yes + literals: + word 7677223365245394977 + word 14318463004604079067 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Leaf2’ + item named ‘$krep8’ + static-construction object ‘$tc'Leaf2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Leaf1’ + utilized items: <none> + static-construction object ‘$krep8’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep7’ + static-construction object ‘$krep7’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcBinTree’ + item named ‘$krep6’ + static-construction object ‘$krep6’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep5’ + static-construction object ‘$krep5’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘[]’ + static-construction object ‘$tcBinTree’: + data constructor name: TyCon + lifted: yes + literals: + word 9824011489556756898 + word 1356349741031249981 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcBinTree2’ + item named ‘krep$*->*->*’ + static-construction object ‘$tcBinTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcBinTree1’ + utilized items: <none> + static-construction object ‘$krep4’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcTuple2’ + item named ‘$krep3’ + static-construction object ‘$krep3’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep2’ + static-construction object ‘$krep2’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$krep1’: + data constructor name: KindRepVar + lifted: yes + literals: word 0 + utilized items: <none> + static-construction object ‘$krep’: + data constructor name: KindRepVar + lifted: yes + literals: word 1 + utilized items: <none> + static-construction object ‘$trModule’: + data constructor name: Module + lifted: yes + literals: <none> + utilized items: + item named ‘$trModule2’ + item named ‘$trModule4’ + static-construction object ‘$trModule4’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule3’ + utilized items: <none> + static-construction object ‘$trModule2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule1’ + utilized items: <none> + ordinary object ‘divides’: + arity: 3 + literals: <none> + utilized items: + ordinary object ‘$dReal’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘$dNum’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘$dEq’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘$dEq1’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘bcprep’: + arity: 5 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 15 + utilized items: + break array of module ‘Example’ + ordinary object ‘divides’: + arity: 1 + literals: + word 0 + info table of ‘IS’ + utilized items: item named ‘fromInteger’ + ordinary object ‘divides’: + arity: 3 + literals: + top-level string "Example" + top-level string "main" + cost center of breakpoint 14 + utilized items: + break array of module ‘Example’ + item named ‘mod’ + item named ‘==’ + item named ‘$p1Ord’ + item named ‘$p2Real’ + item named ‘$p1Real’ + item named ‘$p1Integral’ + ordinary object ‘Node’: + arity: 3 + literals: info table of ‘Node’ + utilized items: <none> + ordinary object ‘Leaf’: + arity: 1 + literals: info table of ‘Leaf’ + utilized items: <none> + ordinary object ‘Nested’: + arity: 1 + literals: info table of ‘Nested’ + utilized items: <none> + ordinary object ‘PerfectTree’: + arity: 1 + literals: info table of ‘PerfectTree’ + utilized items: <none> +data constructor info tables: + info table of ‘PerfectTree’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Nested’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Leaf’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Node’: + number of words for pointers: 3 + number of words for non-pointers: 0 +top-level strings: + $tc'Nested1: "'Nested" + $tc'PerfectTree1: "'PerfectTree" + $tcPerfectTree1: "PerfectTree" + $tc'Node1: "'Node" + $tc'Leaf1: "'Leaf" + $tcBinTree1: "BinTree" + $trModule3: "Example" + $trModule1: "main" +breakpoints: + source breakpoints: + source breakpoint 0: + source span: Example.hs:18:17-25 + declaration path: divides + free variables: + k + n + source breakpoint 1: + source span: Example.hs:18:17-30 + declaration path: divides + free variables: + k + n + source breakpoint 2: + source span: Example.hs:24:27-37 + declaration path: + primes + isPrime + free variables: n + source breakpoint 3: + source span: Example.hs:24:53-56 + declaration path: + primes + isPrime + free variables: n + source breakpoint 4: + source span: Example.hs:24:62-64 + declaration path: + primes + isPrime + free variables: <none> + source breakpoint 5: + source span: Example.hs:24:52-65 + declaration path: + primes + isPrime + free variables: n + source breakpoint 6: + source span: Example.hs:24:41-73 + declaration path: + primes + isPrime + free variables: n + source breakpoint 7: + source span: Example.hs:24:22-74 + declaration path: + primes + isPrime + free variables: n + source breakpoint 8: + source span: Example.hs:24:17-75 + declaration path: + primes + isPrime + free variables: n + source breakpoint 9: + source span: Example.hs:21:14-34 + declaration path: primes + free variables: isPrime + source breakpoint 10: + source span: Example.hs:21:10-34 + declaration path: primes + free variables: isPrime + source breakpoint 11: + source span: Example.hs:27:13-25 + declaration path: primesPtr + free variables: <none> + source breakpoint 12: + source span: Example.hs:12:30-70 + declaration path: + fibonaccis + positiveFibonaccis + free variables: positiveFibonaccis + source breakpoint 13: + source span: Example.hs:12:26-70 + declaration path: + fibonaccis + positiveFibonaccis + free variables: positiveFibonaccis + source breakpoint 14: + source span: Example.hs:9:14-35 + declaration path: fibonaccis + free variables: positiveFibonaccis + source breakpoint 15: + source span: Example.hs:15:17-33 + declaration path: fibonaccisPtr + free variables: <none> + bytecode breakpoints: + bytecode breakpoint 0: + type: StaticPtr [Natural] + type variables: <none> + variables: <none> + corresponding source breakpoint: 11 + bytecode breakpoint 1: + type: [Natural] + type variables: <none> + variables: <unknown> + corresponding source breakpoint: 9 + bytecode breakpoint 2: + type: [Natural] + type variables: <none> + variables: <unknown> + corresponding source breakpoint: 10 + bytecode breakpoint 3: + type: Natural -> Bool + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 2 + bytecode breakpoint 4: + type: Natural -> Bool + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 3 + bytecode breakpoint 5: + type: Natural -> Natural + type variables: <none> + variables: <none> + corresponding source breakpoint: 4 + bytecode breakpoint 6: + type: Natural -> Bool + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 5 + bytecode breakpoint 7: + type: [Natural] + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 6 + bytecode breakpoint 8: + type: Bool + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 7 + bytecode breakpoint 9: + type: Bool + type variables: <none> + variables: %'Many n :: Natural + corresponding source breakpoint: 8 + bytecode breakpoint 10: + type: StaticPtr [Natural] + type variables: <none> + variables: <none> + corresponding source breakpoint: 15 + bytecode breakpoint 11: + type: [Natural] + type variables: <none> + variables: <unknown> + corresponding source breakpoint: 14 + bytecode breakpoint 12: + type: [Natural] + type variables: <none> + variables: <unknown> + corresponding source breakpoint: 12 + bytecode breakpoint 13: + type: [Natural] + type variables: <none> + variables: <unknown> + corresponding source breakpoint: 13 + bytecode breakpoint 14: + type: a + type variables: a :: * + variables: + %'Many eta :: a + %'Many eta1 :: a + corresponding source breakpoint: 0 + bytecode breakpoint 15: + type: Bool + type variables: a :: * + variables: + %'Many eta :: a + %'Many eta1 :: a + corresponding source breakpoint: 1 +static-pointer table entries: + ed7a1b0a13717c34cc10ea39e61d12f0: static + 213042ce5bda1667c6629602bbd55756: static +HPC information: <none> + ===================================== testsuite/tests/show-bytecode/show-bytecode-hpc.stdout ===================================== @@ -0,0 +1,668 @@ +[1 of 1] Compiling Example ( Example.hs, Example.gbc ) +name: Example +hash: f980f4ded430c2b38783bc705ca167a5 +objects: + ordinary object ‘primesPtr’: + arity: 0 + literals: + label ‘’ + label ‘’ + utilized items: + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 2391484856205448807 + word 14295153105712797526 + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 27 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 20 + utilized items: <none> + ordinary object ‘static’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘primes’ + ordinary object ‘primes2’: + arity: 0 + literals: label ‘’ + utilized items: + ordinary object ‘primes2’: + arity: 0 + literals: label ‘’ + utilized items: + ordinary object ‘primes2’: + arity: 0 + literals: + label ‘’ + word 3 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + item named ‘$fEnumNatural’ + item named ‘enumFrom’ + ordinary object ‘primes2’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘isPrime’ + item named ‘filter’ + ordinary object ‘isPrime’: + arity: 1 + literals: + label ‘’ + label ‘’ + utilized items: + ordinary object ‘isPrime’: + arity: 1 + literals: label ‘’ + utilized items: + ordinary object ‘isPrime’: + arity: 1 + literals: label ‘’ + utilized items: + ordinary object ‘isPrime’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘primes’ + ordinary object ‘isPrime’: + arity: 1 + literals: label ‘’ + utilized items: + ordinary object ‘isPrime’: + arity: 0 + literals: label ‘’ + utilized items: + ordinary object ‘v’: + arity: 0 + literals: label ‘’ + utilized items: + item named ‘$fIntegralInteger’ + item named ‘$fNumNatural’ + item named ‘^’ + ordinary object ‘v1’: + arity: 0 + literals: + label ‘’ + word 2 + info table of ‘IS’ + utilized items: <none> + ordinary object ‘pap’: + arity: 3 + literals: <none> + utilized items: <none> + ordinary object ‘isPrime’: + arity: 1 + literals: label ‘’ + utilized items: + ordinary object ‘v’: + arity: 0 + literals: label ‘’ + utilized items: + item named ‘$fOrdNatural’ + item named ‘<=’ + ordinary object ‘v1’: + arity: 1 + literals: label ‘’ + utilized items: <none> + ordinary object ‘pap’: + arity: 3 + literals: <none> + utilized items: <none> + item named ‘.’ + item named ‘takeWhile’ + ordinary object ‘isPrime’: + arity: 1 + literals: label ‘’ + utilized items: + ordinary object ‘v’: + arity: 0 + literals: label ‘’ + utilized items: + ordinary object ‘pap’: + arity: 2 + literals: <none> + utilized items: + item named ‘$fIntegralNatural’ + item named ‘divides’ + ordinary object ‘v1’: + arity: 1 + literals: label ‘’ + utilized items: <none> + ordinary object ‘pap’: + arity: 3 + literals: <none> + utilized items: <none> + item named ‘$fFoldableList’ + item named ‘any’ + item named ‘not’ + ordinary object ‘primes’: + arity: 0 + literals: + label ‘’ + label ‘’ + info table of ‘:’ + utilized items: + item named ‘primes2’ + item named ‘primes1’ + ordinary object ‘primes1’: + arity: 0 + literals: + label ‘’ + word 2 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + ordinary object ‘fibonaccisPtr’: + arity: 0 + literals: + label ‘’ + label ‘’ + utilized items: + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 17112019464237448244 + word 14704510317759369968 + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 15 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 24 + utilized items: <none> + ordinary object ‘static’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘fibonaccis’ + ordinary object ‘positiveFibonaccis1’: + arity: 0 + literals: + label ‘’ + label ‘’ + info table of ‘:’ + utilized items: + item named ‘positiveFibonaccis2’ + item named ‘positiveFibonaccis’ + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: label ‘’ + utilized items: + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘positiveFibonaccis1’ + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘fibonaccis’ + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: label ‘’ + utilized items: + item named ‘$fNumNatural’ + item named ‘+’ + item named ‘zipWith’ + ordinary object ‘fibonaccis’: + arity: 0 + literals: + label ‘’ + label ‘’ + info table of ‘:’ + utilized items: + item named ‘fibonaccis2’ + item named ‘fibonaccis1’ + ordinary object ‘fibonaccis2’: + arity: 0 + literals: label ‘’ + utilized items: item named ‘positiveFibonaccis1’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: + label ‘’ + word 1 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + ordinary object ‘fibonaccis1’: + arity: 0 + literals: + label ‘’ + word 0 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + ordinary object ‘$dTypeable2’: + arity: 0 + literals: <none> + utilized items: + item named ‘$dTypeable’ + item named ‘$dTypeable1’ + item named ‘mkTrAppChecked’ + ordinary object ‘$dTypeable1’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcList’ + item named ‘mkTrCon’ + ordinary object ‘$dTypeable’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcNatural’ + item named ‘mkTrCon’ + static-construction object ‘$tc'Nested’: + data constructor name: TyCon + lifted: yes + literals: + word 4886352401159288042 + word 15486177717927261000 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Nested2’ + item named ‘$krep17’ + static-construction object ‘$tc'Nested2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Nested1’ + utilized items: <none> + static-construction object ‘$krep17’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep16’ + item named ‘$krep13’ + static-construction object ‘$krep16’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep15’ + static-construction object ‘$krep15’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep4’ + item named ‘[]’ + static-construction object ‘$tc'PerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 1216274636751977258 + word 143956009589726941 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'PerfectTree2’ + item named ‘$krep14’ + static-construction object ‘$tc'PerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'PerfectTree1’ + utilized items: <none> + static-construction object ‘$krep14’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep13’ + static-construction object ‘$krep13’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep12’ + static-construction object ‘$krep12’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$tcPerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 11330648440307610868 + word 17396431681782259314 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcPerfectTree2’ + item named ‘krep$*Arr*’ + static-construction object ‘$tcPerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcPerfectTree1’ + utilized items: <none> + static-construction object ‘$tc'Node’: + data constructor name: TyCon + lifted: yes + literals: + word 2884468726215238492 + word 558166382591591938 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Node2’ + item named ‘$krep11’ + static-construction object ‘$tc'Node2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Node1’ + utilized items: <none> + static-construction object ‘$krep11’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep10’ + static-construction object ‘$krep10’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘$krep9’ + static-construction object ‘$krep9’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep7’ + static-construction object ‘$tc'Leaf’: + data constructor name: TyCon + lifted: yes + literals: + word 7677223365245394977 + word 14318463004604079067 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Leaf2’ + item named ‘$krep8’ + static-construction object ‘$tc'Leaf2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Leaf1’ + utilized items: <none> + static-construction object ‘$krep8’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep7’ + static-construction object ‘$krep7’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcBinTree’ + item named ‘$krep6’ + static-construction object ‘$krep6’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep5’ + static-construction object ‘$krep5’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘[]’ + static-construction object ‘$tcBinTree’: + data constructor name: TyCon + lifted: yes + literals: + word 9824011489556756898 + word 1356349741031249981 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcBinTree2’ + item named ‘krep$*->*->*’ + static-construction object ‘$tcBinTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcBinTree1’ + utilized items: <none> + static-construction object ‘$krep4’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcTuple2’ + item named ‘$krep3’ + static-construction object ‘$krep3’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep2’ + static-construction object ‘$krep2’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$krep1’: + data constructor name: KindRepVar + lifted: yes + literals: word 0 + utilized items: <none> + static-construction object ‘$krep’: + data constructor name: KindRepVar + lifted: yes + literals: word 1 + utilized items: <none> + static-construction object ‘$trModule’: + data constructor name: Module + lifted: yes + literals: <none> + utilized items: + item named ‘$trModule2’ + item named ‘$trModule4’ + static-construction object ‘$trModule4’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule3’ + utilized items: <none> + static-construction object ‘$trModule2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule1’ + utilized items: <none> + ordinary object ‘divides’: + arity: 3 + literals: <none> + utilized items: + ordinary object ‘$dReal’: + arity: 0 + literals: + label ‘’ + label ‘’ + utilized items: + ordinary object ‘divides’: + arity: 1 + literals: + label ‘’ + word 0 + info table of ‘IS’ + utilized items: + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: item named ‘fromInteger’ + item named ‘$p1Real’ + ordinary object ‘divides’: + arity: 3 + literals: label ‘’ + utilized items: + ordinary object ‘divides’: + arity: 1 + literals: label ‘’ + utilized items: <none> + ordinary object ‘divides’: + arity: 1 + literals: label ‘’ + utilized items: <none> + item named ‘mod’ + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: item named ‘==’ + item named ‘$p1Ord’ + item named ‘$p2Real’ + item named ‘$p1Integral’ + ordinary object ‘Node’: + arity: 3 + literals: info table of ‘Node’ + utilized items: <none> + ordinary object ‘Leaf’: + arity: 1 + literals: info table of ‘Leaf’ + utilized items: <none> + ordinary object ‘Nested’: + arity: 1 + literals: info table of ‘Nested’ + utilized items: <none> + ordinary object ‘PerfectTree’: + arity: 1 + literals: info table of ‘PerfectTree’ + utilized items: <none> +data constructor info tables: + info table of ‘PerfectTree’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Nested’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Leaf’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Node’: + number of words for pointers: 3 + number of words for non-pointers: 0 +top-level strings: + $tc'Nested1: "'Nested" + $tc'PerfectTree1: "'PerfectTree" + $tcPerfectTree1: "PerfectTree" + $tc'Node1: "'Node" + $tc'Leaf1: "'Leaf" + $tcBinTree1: "BinTree" + $trModule3: "Example" + $trModule1: "main" +breakpoints: <none> +static-pointer table entries: + ed7a1b0a13717c34cc10ea39e61d12f0: static + 213042ce5bda1667c6629602bbd55756: static +HPC information: + hash: 000000006110204f + module name: Example + tick box name: + number of ticks: 45 + ===================================== testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout ===================================== @@ -0,0 +1,593 @@ +[1 of 1] Compiling Example ( Example.hs, Example.gbc ) +name: Example +hash: 69e57c48badc5756110a3f9e1ece8f0a +objects: + ordinary object ‘primesPtr’: + arity: 0 + literals: <none> + utilized items: + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 2391484856205448807 + word 14295153105712797526 + utilized items: + item named ‘static’ + item named ‘primes’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 27 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 20 + utilized items: <none> + ordinary object ‘primes2’: + arity: 0 + literals: <none> + utilized items: + item named ‘primes2’ + item named ‘isPrime’ + item named ‘filter’ + ordinary object ‘isPrime’: + arity: 1 + literals: <none> + utilized items: + ordinary object ‘isPrime’: + arity: 1 + literals: <none> + utilized items: + ordinary object ‘isPrime’: + arity: 1 + literals: <none> + utilized items: + ordinary object ‘isPrime’: + arity: 1 + literals: + word 2 + info table of ‘IS’ + utilized items: + ordinary object ‘v’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fIntegralInteger’ + item named ‘$fNumNatural’ + item named ‘^’ + ordinary object ‘isPrime’: + arity: 3 + literals: <none> + utilized items: <none> + ordinary object ‘v’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fOrdNatural’ + item named ‘<=’ + ordinary object ‘isPrime’: + arity: 3 + literals: <none> + utilized items: <none> + item named ‘.’ + item named ‘primes’ + item named ‘takeWhile’ + ordinary object ‘isPrime’: + arity: 2 + literals: <none> + utilized items: + item named ‘$fIntegralNatural’ + item named ‘divides’ + item named ‘$fFoldableList’ + item named ‘any’ + item named ‘not’ + static-construction object ‘primes’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘primes1’ + item named ‘primes2’ + ordinary object ‘primes2’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘primes2’: + arity: 0 + literals: + word 3 + info table of ‘IS’ + utilized items: + item named ‘$fNumNatural’ + item named ‘fromInteger’ + item named ‘$fEnumNatural’ + item named ‘enumFrom’ + ordinary object ‘primes1’: + arity: 0 + literals: <none> + utilized items: + item named ‘primes1’ + item named ‘$fNumNatural’ + item named ‘fromInteger’ + static-construction object ‘primes1’: + data constructor name: IS + lifted: yes + literals: word 2 + utilized items: <none> + ordinary object ‘fibonaccisPtr’: + arity: 0 + literals: <none> + utilized items: + item named ‘static’ + item named ‘$dTypeable2’ + item named ‘$fIsStaticStaticPtr’ + static-construction object ‘static’: + data constructor name: StaticPtr + lifted: yes + literals: + word 17112019464237448244 + word 14704510317759369968 + utilized items: + item named ‘static’ + item named ‘fibonaccis’ + static-construction object ‘static’: + data constructor name: StaticPtrInfo + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + item named ‘static’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "main" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + ordinary object ‘static’: + arity: 0 + literals: top-level string "Example" + utilized items: + ordinary object ‘static’: + arity: 0 + literals: <none> + utilized items: item named ‘unpackCString#’ + static-construction object ‘static’: + data constructor name: (,) + lifted: yes + literals: <none> + utilized items: + item named ‘static’ + item named ‘static’ + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 15 + utilized items: <none> + static-construction object ‘static’: + data constructor name: I# + lifted: yes + literals: word 24 + utilized items: <none> + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: <none> + utilized items: + item named ‘positiveFibonaccis1’ + item named ‘fibonaccis’ + item named ‘positiveFibonaccis2’ + item named ‘zipWith’ + static-construction object ‘positiveFibonaccis1’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘positiveFibonaccis’ + item named ‘positiveFibonaccis2’ + static-construction object ‘fibonaccis’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘fibonaccis1’ + item named ‘positiveFibonaccis1’ + ordinary object ‘positiveFibonaccis2’: + arity: 0 + literals: <none> + utilized items: + item named ‘$fNumNatural’ + item named ‘+’ + ordinary object ‘positiveFibonaccis’: + arity: 0 + literals: <none> + utilized items: + item named ‘positiveFibonaccis’ + item named ‘$fNumNatural’ + item named ‘fromInteger’ + static-construction object ‘positiveFibonaccis’: + data constructor name: IS + lifted: yes + literals: word 1 + utilized items: <none> + ordinary object ‘fibonaccis1’: + arity: 0 + literals: <none> + utilized items: + item named ‘fibonaccis1’ + item named ‘$fNumNatural’ + item named ‘fromInteger’ + static-construction object ‘fibonaccis1’: + data constructor name: IS + lifted: yes + literals: word 0 + utilized items: <none> + ordinary object ‘$dTypeable2’: + arity: 0 + literals: <none> + utilized items: + item named ‘$dTypeable’ + item named ‘$dTypeable1’ + item named ‘mkTrAppChecked’ + ordinary object ‘$dTypeable1’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcList’ + item named ‘mkTrCon’ + ordinary object ‘$dTypeable’: + arity: 0 + literals: info table of ‘[]’ + utilized items: + item named ‘$tcNatural’ + item named ‘mkTrCon’ + static-construction object ‘$tc'Nested’: + data constructor name: TyCon + lifted: yes + literals: + word 4886352401159288042 + word 15486177717927261000 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Nested2’ + item named ‘$krep17’ + static-construction object ‘$tc'Nested2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Nested1’ + utilized items: <none> + static-construction object ‘$krep17’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep16’ + item named ‘$krep13’ + static-construction object ‘$krep16’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep15’ + static-construction object ‘$krep15’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep4’ + item named ‘[]’ + static-construction object ‘$tc'PerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 1216274636751977258 + word 143956009589726941 + word 1 + utilized items: + item named ‘$trModule’ + item named ‘$tc'PerfectTree2’ + item named ‘$krep14’ + static-construction object ‘$tc'PerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'PerfectTree1’ + utilized items: <none> + static-construction object ‘$krep14’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep13’ + static-construction object ‘$krep13’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcPerfectTree’ + item named ‘$krep12’ + static-construction object ‘$krep12’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$tcPerfectTree’: + data constructor name: TyCon + lifted: yes + literals: + word 11330648440307610868 + word 17396431681782259314 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcPerfectTree2’ + item named ‘krep$*Arr*’ + static-construction object ‘$tcPerfectTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcPerfectTree1’ + utilized items: <none> + static-construction object ‘$tc'Node’: + data constructor name: TyCon + lifted: yes + literals: + word 2884468726215238492 + word 558166382591591938 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Node2’ + item named ‘$krep11’ + static-construction object ‘$tc'Node2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Node1’ + utilized items: <none> + static-construction object ‘$krep11’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep10’ + static-construction object ‘$krep10’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘$krep9’ + static-construction object ‘$krep9’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep7’ + item named ‘$krep7’ + static-construction object ‘$tc'Leaf’: + data constructor name: TyCon + lifted: yes + literals: + word 7677223365245394977 + word 14318463004604079067 + word 2 + utilized items: + item named ‘$trModule’ + item named ‘$tc'Leaf2’ + item named ‘$krep8’ + static-construction object ‘$tc'Leaf2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tc'Leaf1’ + utilized items: <none> + static-construction object ‘$krep8’: + data constructor name: KindRepFun + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep7’ + static-construction object ‘$krep7’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcBinTree’ + item named ‘$krep6’ + static-construction object ‘$krep6’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep5’ + static-construction object ‘$krep5’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep’ + item named ‘[]’ + static-construction object ‘$tcBinTree’: + data constructor name: TyCon + lifted: yes + literals: + word 9824011489556756898 + word 1356349741031249981 + word 0 + utilized items: + item named ‘$trModule’ + item named ‘$tcBinTree2’ + item named ‘krep$*->*->*’ + static-construction object ‘$tcBinTree2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$tcBinTree1’ + utilized items: <none> + static-construction object ‘$krep4’: + data constructor name: KindRepTyConApp + lifted: yes + literals: <none> + utilized items: + item named ‘$tcTuple2’ + item named ‘$krep3’ + static-construction object ‘$krep3’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘$krep2’ + static-construction object ‘$krep2’: + data constructor name: : + lifted: yes + literals: <none> + utilized items: + item named ‘$krep1’ + item named ‘[]’ + static-construction object ‘$krep1’: + data constructor name: KindRepVar + lifted: yes + literals: word 0 + utilized items: <none> + static-construction object ‘$krep’: + data constructor name: KindRepVar + lifted: yes + literals: word 1 + utilized items: <none> + static-construction object ‘$trModule’: + data constructor name: Module + lifted: yes + literals: <none> + utilized items: + item named ‘$trModule2’ + item named ‘$trModule4’ + static-construction object ‘$trModule4’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule3’ + utilized items: <none> + static-construction object ‘$trModule2’: + data constructor name: TrNameS + lifted: yes + literals: address ‘$trModule1’ + utilized items: <none> + ordinary object ‘divides’: + arity: 3 + literals: <none> + utilized items: + ordinary object ‘$dReal’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘divides’: + arity: 1 + literals: + word 0 + info table of ‘IS’ + utilized items: + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: item named ‘fromInteger’ + item named ‘$p1Real’ + ordinary object ‘divides’: + arity: 3 + literals: <none> + utilized items: item named ‘mod’ + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: + ordinary object ‘divides’: + arity: 0 + literals: <none> + utilized items: item named ‘==’ + item named ‘$p1Ord’ + item named ‘$p2Real’ + item named ‘$p1Integral’ + ordinary object ‘Node’: + arity: 3 + literals: info table of ‘Node’ + utilized items: <none> + ordinary object ‘Leaf’: + arity: 1 + literals: info table of ‘Leaf’ + utilized items: <none> + ordinary object ‘Nested’: + arity: 1 + literals: info table of ‘Nested’ + utilized items: <none> + ordinary object ‘PerfectTree’: + arity: 1 + literals: info table of ‘PerfectTree’ + utilized items: <none> +data constructor info tables: + info table of ‘PerfectTree’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Nested’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Leaf’: + number of words for pointers: 1 + number of words for non-pointers: 0 + info table of ‘Node’: + number of words for pointers: 3 + number of words for non-pointers: 0 +top-level strings: + $tc'Nested1: "'Nested" + $tc'PerfectTree1: "'PerfectTree" + $tcPerfectTree1: "PerfectTree" + $tc'Node1: "'Node" + $tc'Leaf1: "'Leaf" + $tcBinTree1: "BinTree" + $trModule3: "Example" + $trModule1: "main" +breakpoints: <none> +static-pointer table entries: + ed7a1b0a13717c34cc10ea39e61d12f0: static + 213042ce5bda1667c6629602bbd55756: static +HPC information: <none> + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ead5f6b1fd2ce10bb9347f1a67afce7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ead5f6b1fd2ce10bb9347f1a67afce7… 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/andreask/arm-ffi] Wibbles
by Andreas Klebinger (＠AndreasK) 14 Jul '26

14 Jul '26

Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: bf2663c0 by Andreas Klebinger at 2026-07-14T19:45:07+02:00 Wibbles - - - - - 1 changed file: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -358,43 +358,6 @@ data Register = Fixed Format Reg InstrBlock | Any Format (Reg -> InstrBlock) -registerFormat :: Register -> Format -registerFormat reg = case reg of { Fixed format _ _ -> format; Any format _ -> format } --- | Sometimes we need to change the Format of a register. Primarily during --- conversion. When shrinking the register below machine word size we zero the high --- bits. See Note [Signed arithmetic on AArch64] - -swizzleRegisterRep :: Width -> Format -> Register -> Register -swizzleRegisterRep old_width format reg - -- APK: Currently this assertion doesn't always hold. - -- This seems problematic but will have to be fixed another time. - | (reg_width /= old_width) - , pprTrace "Missmatched widths" (ppr (old_width, format, reg)) False - = undefined - - | old_width == formatToWidth format = - reg - -- The CMM needs to expect garbage in high bits so this is fine. - | old_width < f_width || format >= II32 = - reg - | otherwise = truncateSmaller reg - where - f_width = formatToWidth format - reg_width = formatToWidth (registerFormat reg) - trunc_instr = case f_width of - W8 -> UXTB - W16 -> UXTH - _ -> panic "unexpected width" - truncateSmaller (Fixed _fmt_in reg old_code) = - let reg_code = old_code `snocOL` - trunc_instr (OpReg old_width reg) (OpReg W32 reg) - in Fixed format reg reg_code - truncateSmaller (Any _fmt_in codefn) = - let reg_code = \reg -> - codefn reg `snocOL` - trunc_instr (OpReg old_width reg) (OpReg W32 reg) - in Any format reg_code - -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg @@ -983,7 +946,13 @@ getRegister' config plat expr where fmt = intFormat w -- Conversions - MO_XX_Conv from to -> swizzleRegisterRep from (intFormat to) <$> getRegister e + MO_XX_Conv from to + | to >= W32 || to > from -> + -- We don't care about garbage high bits when upcasting this way. + pure $ Fixed (intFormat to) reg code + | otherwise -> do + (trunc_reg, code_trunc) <- truncateReg from to reg + return $ Fixed (intFormat to) trunc_reg (code `appOL` code_trunc) -- Vector MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg)) @@ -1929,7 +1898,7 @@ signExtendReg w w' r = | otherwise -> extend SXTW W16 -> extend SXTH W8 -> extend SXTB - _ -> panic "intOp" + _ -> panic "signExtendReg:unexpectedWidth" where noop = return (r, nilOL) extend instr = do @@ -1939,20 +1908,20 @@ signExtendReg w w' r = -- | Instructions to truncate (zero extend) the value in the given register from width @w@ -- down to width @w'@ into a new register. Or return the original register if it's a noop. truncateReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) -truncateReg w w' r = do - case w' of +truncateReg w_from w_to r = do + case w_to of W64 -> noop W32 - | w' == W32 -> noop + | w_from == W32 -> noop | otherwise -> trunc MOV W16 -> trunc UXTH W8 -> trunc UXTB - _ -> panic "intOp" + _ -> panic "truncateReg:unexpectedWidth" where noop = return (r, nilOL) trunc instr = do - r' <- getNewRegNat (intFormat w') - return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) + r' <- getNewRegNat (intFormat w_to) + return (r', unitOL $ instr (OpReg W32 r') (OpReg W32 r)) -- | Instructions to truncate (zero extend) the value in the given register from width @w@ -- down to width @w'@. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf2663c0954db0ee04db6e8a8ae30f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf2663c0954db0ee04db6e8a8ae30f5… 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/marge_bot_batch_merge_job] 5 commits: hadrian: fix HLS support
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: a724ef5f by Cheng Shao at 2026-07-14T12:39:12-04:00 hadrian: fix HLS support This patch fixes hadrian's HLS support so one can rely on HLS when working on the hadrian codebase. Fixes #27480. Not building/linking shared libraries for hadrian is a severely premature optimization; this top-level setting in `cabal.project` only affects home packages while the dependencies in the cabal store are built with vanilla/dynamic anyway, and even adding dynamic builds to home packages would not be costly due to cabal's usage of `-dynamic-too`. - - - - - 5b8dfeb2 by Cheng Shao at 2026-07-14T12:39:12-04:00 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> - - - - - de07f85c by Alan Zimmerman at 2026-07-14T12:39:13-04: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 - - - - - 54e8aa69 by Andreas Klebinger at 2026-07-14T12:39:14-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. - - - - - 05cf34f9 by Cheng Shao at 2026-07-14T12:39:15-04:00 testsuite: fix bytecodeIPE test under +ipe flavours This patch fixes the bytecodeIPE test under +ipe flavours. It used to fail under +ipe because the RTS is built with IPE info, then stg_AP_info in RTS carries IPE info, so whereFrom wouldn't return Nothing. Now the test checks IPE info of a datacon in the ghci-loaded module which is not affected by whether the RTS is built with IPE info or not. Fixes #27498. Co-authored-by: Codex <codex(a)openai.com> - - - - - 32 changed files: - + changelog.d/fix-cmm-atomic-load-store - compiler/GHC/Cmm/Parser.y - 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 - hadrian/cabal.project - nofib - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - testsuite/tests/ghci/scripts/bytecodeIPE.hs - 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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7703f426f7e7a9c63adb2c7076e3af… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7703f426f7e7a9c63adb2c7076e3af… 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] Pushed new branch wip/romes/27053
by Rodrigo Mesquita (＠alt-romes) 14 Jul '26

14 Jul '26

Rodrigo Mesquita pushed new branch wip/romes/27053 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/27053 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