- ghc-commits - Haskell.org

[Git][ghc/ghc][master] TTG: Add extension points to BooleanFormula
by Marge Bot (＠marge-bot) 18 Aug '26

18 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d8f1a2a3 by Alan Zimmerman at 2026-08-17T12:13:18-04:00 TTG: Add extension points to BooleanFormula They are currently unused, but will be used for exact print annotations next, allowing us to get rid of LocatedBF / SrcSpanAnnBF - - - - - 14 changed files: - compiler/GHC/Core/Class.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/TyCl/Class.hs - compiler/Language/Haskell/Syntax/BooleanFormula.hs - compiler/Language/Haskell/Syntax/Extension.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Core/Class.hs ===================================== @@ -41,6 +41,7 @@ import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Outputable +import GHC.Data.BooleanFormula () -- for BooleanFormulaDefault instance import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue ) import qualified Data.Data as Data ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -542,10 +542,11 @@ toIfGuidance src guidance toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula toIfaceBooleanFormula = go where - go (BF.Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm - go (BF.And bfs ) = IfAnd $ map (go . unLoc) bfs - go (BF.Or bfs ) = IfOr $ map (go . unLoc) bfs - go (BF.Parens bf) = IfParens $ (go . unLoc) bf + go (BF.Var _ nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm + go (BF.And _ bfs ) = IfAnd $ map (go . unLoc) bfs + go (BF.Or _ bfs ) = IfOr $ map (go . unLoc) bfs + go (BF.Parens _ bf) = IfParens $ (go . unLoc) bf + go (BF.XBooleanFormula _) = panic "toIfaceBooleanFormula" {- ************************************************************************ ===================================== compiler/GHC/Data/BooleanFormula.hs ===================================== @@ -27,7 +27,10 @@ import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable import GHC.Parser.Annotation ( SrcSpanAnnBF ) import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) -import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP) +import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP, + noExtField, NoExtField, DataConCantHappen, + XBFVar, XBFAnd, XBFOr, XBFParens, + XXBooleanFormula) import Language.Haskell.Syntax.BooleanFormula @@ -37,6 +40,17 @@ import Language.Haskell.Syntax.BooleanFormula type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnBF +type instance XBFVar (GhcPass _) = NoExtField +type instance XBFAnd (GhcPass _) = NoExtField +type instance XBFOr (GhcPass _) = NoExtField +type instance XBFParens (GhcPass _) = NoExtField +type instance XXBooleanFormula (GhcPass _) = DataConCantHappen + +instance BooleanFormulaDefault (GhcPass p) where + bfAnnAnd = noExtField + bfAnnOr = noExtField + + -- if we had Functor/Traversable (LbooleanFormula p) we could use that -- as a constraint and we wouldn't need to specialize to just GhcPass p, -- but becuase LBooleanFormula is a type synonym such a constraint is @@ -49,10 +63,10 @@ bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p')) -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p') bfMap f = go where - go (Var a ) = Var $ f a - go (And bfs) = And $ map (fmap go) bfs - go (Or bfs) = Or $ map (fmap go) bfs - go (Parens bf ) = Parens $ fmap go bf + go (Var x a ) = Var x $ f a + go (And x bfs) = And x $ map (fmap go) bfs + go (Or x bfs) = Or x $ map (fmap go) bfs + go (Parens x bf ) = Parens x $ fmap go bf bfTraverse :: Applicative f => (LIdP (GhcPass p) -> f (LIdP (GhcPass p'))) @@ -60,10 +74,10 @@ bfTraverse :: Applicative f -> f (BooleanFormula (GhcPass p')) bfTraverse f = go where - go (Var a ) = Var <$> f a - go (And bfs) = And <$> traverse @[] (traverse go) bfs - go (Or bfs) = Or <$> traverse @[] (traverse go) bfs - go (Parens bf ) = Parens <$> traverse go bf + go (Var x a ) = Var x <$> f a + go (And x bfs) = And x <$> traverse @[] (traverse go) bfs + go (Or x bfs) = Or x <$> traverse @[] (traverse go) bfs + go (Parens x bf ) = Parens x <$> traverse go bf @@ -106,18 +120,18 @@ We don't show a ridiculous error message like ---------------------------------------------------------------------- isFalse :: BooleanFormula (GhcPass p) -> Bool -isFalse (Or []) = True +isFalse (Or _ []) = True isFalse _ = False isTrue :: BooleanFormula (GhcPass p) -> Bool -isTrue (And []) = True +isTrue (And _ []) = True isTrue _ = False eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool -eval f (Var x) = f x -eval f (And xs) = all (eval f . unLoc) xs -eval f (Or xs) = any (eval f . unLoc) xs -eval f (Parens x) = eval f (unLoc x) +eval f (Var _ x) = f x +eval f (And _ xs) = all (eval f . unLoc) xs +eval f (Or _ xs) = any (eval f . unLoc) xs +eval f (Parens _ x) = eval f (unLoc x) -- Simplify a boolean formula. -- The argument function should give the truth of the atoms, or Nothing if undecided. @@ -125,12 +139,12 @@ simplify :: forall p. Eq (LIdP (GhcPass p)) => (LIdP (GhcPass p) -> Maybe Bool) -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -simplify f (Var a) = case f a of - Nothing -> Var a +simplify f (Var x a) = case f a of + Nothing -> Var x a Just b -> mkBool b -simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs) -simplify f (Or xs) = mkOr (map (fmap (simplify f)) xs) -simplify f (Parens x) = simplify f (unLoc x) +simplify f (And _ xs) = mkAnd (map (fmap (simplify f)) xs) +simplify f (Or _ xs) = mkOr (map (fmap (simplify f)) xs) +simplify f (Parens _ x) = simplify f (unLoc x) -- Test if a boolean formula is satisfied when the given values are assigned to the atoms -- if it is, returns Nothing @@ -152,11 +166,11 @@ isUnsatisfied f bf -- If the boolean formula holds, does that mean that the given atom is always true? impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool -Var x `impliesAtom` y = (unLoc x) == (unLoc y) -And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs - -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs -Parens x `impliesAtom` y = unLoc x `impliesAtom` y +Var _ x `impliesAtom` y = (unLoc x) == (unLoc y) +And _ xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or _ xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs +Parens _ x `impliesAtom` y = unLoc x `impliesAtom` y implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) @@ -164,18 +178,18 @@ implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool go l@Clause{ clauseExprs = hyp:hyps } r = case hyp of - Var x | memberClauseAtoms (unLoc x) r -> True - | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r - Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r - And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r - Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + Var _ x | memberClauseAtoms (unLoc x) r -> True + | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r + Parens _ hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And _ hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or _ hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' go l r@Clause{ clauseExprs = con:cons } = case con of - Var x | memberClauseAtoms (unLoc x) l -> True - | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } - Parens con' -> go l r { clauseExprs = unLoc con':cons } - And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' - Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + Var _ x | memberClauseAtoms (unLoc x) l -> True + | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } + Parens _ con' -> go l r { clauseExprs = unLoc con':cons } + And _ cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or _ cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } go _ _ = False -- A small sequent calculus proof engine. @@ -201,12 +215,12 @@ pprBooleanFormula' :: (Rational -> LIdP (GhcPass p) -> SDoc) -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula' pprVar pprAnd pprOr = go where - go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) empty - go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) - go _ (Or []) = keyword $ text "FALSE" - go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) - go p (Parens x) = go p (unLoc x) + go p (Var _ x) = pprVar p x + go p (And _ []) = cparen (p > 0) empty + go p (And _ xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or _ []) = keyword $ text "FALSE" + go p (Or _ xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens _ x) = go p (unLoc x) -- Pretty print in source syntax, "a | b | c,d,e" pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc) @@ -233,8 +247,9 @@ instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNormal = go where - go (Var x) = pprPrefixOcc (unLoc x) - go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) - go (Or []) = keyword $ text "FALSE" - go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) - go (Parens x) = parens (go $ unLoc x) + go (Var _ x) = pprPrefixOcc (unLoc x) + go (And _ xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or _ []) = keyword $ text "FALSE" + go (Or _ xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens _ x) = parens (go $ unLoc x) + go (XBooleanFormula _) = text "XBooleanFormula" ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2083,16 +2083,16 @@ instance ToHie PendingRnSplice where instance (HiePass p, Data (IdGhcP p)) => ToHie (GenLocated SrcSpanAnnBF (BooleanFormula (GhcPass p))) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of - Var a -> + Var _ a -> [ toHie $ C Use a ] - And forms -> + And _ forms -> [ toHie forms ] - Or forms -> + Or _ forms -> [ toHie forms ] - Parens f -> + Parens _ f -> [ toHie f ] ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -103,6 +103,7 @@ import GHC.Data.FastString import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (noExtField) import Language.Haskell.Syntax.Text import Control.Monad @@ -1326,10 +1327,10 @@ pprIfaceDecl ss decl@(IfaceClass { ifName = clas fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else. - fromIfaceBooleanFormula (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm - fromIfaceBooleanFormula (IfAnd bfs ) = And $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfOr bfs ) = Or $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfParens bf) = Parens $ (noLocA . fromIfaceBooleanFormula) bf + fromIfaceBooleanFormula (IfVar nm ) = Var noExtField $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm + fromIfaceBooleanFormula (IfAnd bfs ) = And noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfOr bfs ) = Or noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfParens bf) = Parens noExtField $ (noLocA . fromIfaceBooleanFormula) bf -- See Note [Suppressing binder signatures] in GHC.Iface.Type ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -883,10 +883,10 @@ tc_iface_decl _parent ignore_prags return (ATI tc mb_def) tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) - tc_boolean_formula (IfAnd ibfs ) = BF.And . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfOr ibfs ) = BF.Or . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfParens ibf) = BF.Parens . noLocA <$> tc_boolean_formula ibf - tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) + tc_boolean_formula (IfAnd ibfs ) = BF.And NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfOr ibfs ) = BF.Or NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfParens ibf) = BF.Parens NoExtField . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfVar nm ) = BF.Var NoExtField . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) mk_sc_doc pred = text "Superclass" <+> ppr pred mk_at_doc tc = text "Associated type" <+> ppr tc ===================================== compiler/GHC/Parser.y ===================================== @@ -3821,11 +3821,11 @@ name_boolformula :: { LBooleanFormula GhcPs } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula {% do { h <- addTrailingVbarBF $1 (epTok $2) - ; return (sLLa $1 $> (Or [h,$3])) } } + ; return (sLLa $1 $> (Or noExtField [h,$3])) } } name_boolformula_and :: { LBooleanFormula GhcPs } : name_boolformula_and_list - { sLLa (head $1) (last $1) (And (toList $1)) } + { sLLa (head $1) (last $1) (And noExtField (toList $1)) } name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } : name_boolformula_atom { NE.singleton $1 } @@ -3834,9 +3834,9 @@ name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } ; return (h NE.<| $3) } } name_boolformula_atom :: { LBooleanFormula GhcPs } - : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2)) + : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens noExtField $2)) (AnnBooleanFormula (epTok $1) (epTok $3) []) } - | name_var { sL1a $1 (Var $1) } + | name_var { sL1a $1 (Var noExtField $1) } namelist :: { Located [LocatedN RdrName] } namelist : name_var { sL1 $1 [$1] } ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -345,7 +345,7 @@ tcClassMinimalDef _clas sigs op_info where -- By default require all methods without a default implementation defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLocA (mkVar (noLocA name)) + defMindef = mkAnd [ noLocA (mkVar NoExtField (noLocA name)) | (name, _, Nothing) <- op_info ] instantiateMethod :: Class -> TcId -> [TcType] -> TcType ===================================== compiler/Language/Haskell/Syntax/BooleanFormula.hs ===================================== @@ -4,59 +4,78 @@ module Language.Haskell.Syntax.BooleanFormula( BooleanFormula(..), LBooleanFormula, - mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr + mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr, + BooleanFormulaDefault(..) ) where import Prelude hiding ( init, last ) import Data.List ( nub ) -import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP) +import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP, + XBFVar, XBFAnd, XBFOr, XBFParens, + XXBooleanFormula) -- types type LBooleanFormula p = XRec p (BooleanFormula p) -data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p] - | Parens (LBooleanFormula p) +data BooleanFormula p + = Var (XBFVar p) (LIdP p) + | And (XBFAnd p) [LBooleanFormula p] + | Or (XBFOr p) [LBooleanFormula p] + | Parens (XBFParens p) (LBooleanFormula p) + | XBooleanFormula !(XXBooleanFormula p) + +class BooleanFormulaDefault p where + bfAnnAnd :: XBFAnd p + bfAnnOr :: XBFOr p -- instances -deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p) +deriving instance (Eq (LIdP p), Eq (LBooleanFormula p), + Eq (XBFVar p), + Eq (XBFAnd p), + Eq (XBFOr p), + Eq (XBFParens p), + Eq (XXBooleanFormula p) + ) => Eq (BooleanFormula p) -- smart constructors -- see note [Simplification of BooleanFormulas] -mkVar :: LIdP p -> BooleanFormula p +mkVar :: XBFVar p -> LIdP p -> BooleanFormula p mkVar = Var -mkFalse, mkTrue :: BooleanFormula p -mkFalse = Or [] -mkTrue = And [] +mkFalse, mkTrue :: forall p. BooleanFormulaDefault p => BooleanFormula p +mkFalse = Or (bfAnnOr @p) [] +mkTrue = And (bfAnnAnd @p) [] -- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula p +mkBool :: BooleanFormulaDefault p => Bool -> BooleanFormula p mkBool False = mkFalse mkBool True = mkTrue -- Make a conjunction, and try to simplify -mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p), BooleanFormulaDefault p) + => [LBooleanFormula p] -> BooleanFormula p mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd where -- See Note [Simplification of BooleanFormulas] fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p] fromAnd bf = case unXRec @p bf of - (And xs) -> Just xs + (And _ xs) -> Just xs -- assume that xs are already simplified -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - (Or []) -> Nothing + (Or _ []) -> Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse _ -> Just [bf] mkAnd' [x] = unXRec @p x - mkAnd' xs = And xs + mkAnd' xs = And (bfAnnAnd @p) xs -mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p), BooleanFormulaDefault p) + => [LBooleanFormula p] -> BooleanFormula p mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr where -- See Note [Simplification of BooleanFormulas] fromOr bf = case unXRec @p bf of - (Or xs) -> Just xs - (And []) -> Nothing - _ -> Just [bf] + (Or _ xs) -> Just xs + (And _ []) -> Nothing + _ -> Just [bf] mkOr' [x] = unXRec @p x - mkOr' xs = Or xs + mkOr' xs = Or (bfAnnOr @p) xs ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -841,6 +841,14 @@ type family XXIntegralLit x type family XStringLit x type family XXStringLit x +-- ===================================================================== +-- BooleanFormula type families + +type family XBFVar p +type family XBFAnd p +type family XBFOr p +type family XBFParens p +type family XXBooleanFormula p -- ===================================================================== -- Misc ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2722,18 +2722,18 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (BF.Var x) = do + exact (BF.Var e x) = do x' <- markAnnotated x - return (BF.Var x') - exact (BF.Or ls) = do + return (BF.Var e x') + exact (BF.Or e ls) = do ls' <- mapM markAnnotated ls - return (BF.Or ls') - exact (BF.And ls) = do + return (BF.Or e ls') + exact (BF.And e ls) = do ls' <- mapM markAnnotated ls - return (BF.And ls') - exact (BF.Parens x) = do + return (BF.And e ls') + exact (BF.Parens e x) = do x' <- markAnnotated x - return (BF.Parens x') + return (BF.Parens e x') -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -998,26 +998,26 @@ ppClassDecl -- Minimal complete definition minimalBit = case [s | MinimalSig _ (L _ s) <- sigs] of -- Miminal complete definition = every shown method - And xs : _ - | sort [getName n | L _ (Var (L _ n)) <- xs] + And _ xs : _ + | sort [getName n | L _ (Var _ (L _ n)) <- xs] == sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method - Var (L _ n) : _ + Var _ (L _ n) : _ | [getName n] == [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) + And _ [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) m : _ -> subMinimal $ ppMinimal False m _ -> noHtml - ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs + ppMinimal _ (Var _ (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And _ fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or _ fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id - ppMinimal p (Parens x) = ppMinimal p (unLoc x) + ppMinimal p (Parens _ x) = ppMinimal p (unLoc x) -- Instances instancesBit = ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -858,10 +858,10 @@ bfTraverse :: Applicative f -> f (BooleanFormula DocNameI) bfTraverse f = go where - go (Var a ) = Var <$> f a - go (And bfs) = And <$> traverse @[] (traverse go) bfs - go (Or bfs) = Or <$> traverse @[] (traverse go) bfs - go (Parens bf ) = Parens <$> traverse go bf + go (Var x a ) = Var x <$> f a + go (And x bfs) = And x <$> traverse @[] (traverse go) bfs + go (Or x bfs) = Or x <$> traverse @[] (traverse go) bfs + go (Parens x bf ) = Parens x <$> traverse go bf renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport _ modifiers lname ltype x) = do ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -1038,6 +1038,12 @@ type instance XCTyFamInstDecl DocNameI = NoExtField type instance XHsContext DocNameI = NoExtField type instance XXHsContextDetails DocNameI = DataConCantHappen +type instance XBFVar DocNameI = NoExtField +type instance XBFAnd DocNameI = NoExtField +type instance XBFOr DocNameI = NoExtField +type instance XBFParens DocNameI = NoExtField +type instance XXBooleanFormula DocNameI = DataConCantHappen + ----------------------------------------------------------------------------- -- * NFData instances for GHC types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f1a2a3a6507d9b8a8e556e6afdeec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f1a2a3a6507d9b8a8e556e6afdeec… 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] Simplify comparison in DFM.hs
by Marge Bot (＠marge-bot) 18 Aug '26

18 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 574c875f by Andreas Klebinger at 2026-08-17T12:12:39-04:00 Simplify comparison in DFM.hs Fixes #27669 - - - - - 5 changed files: - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Data/Word64Map/Strict.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -72,6 +72,7 @@ module GHC.Data.Word64Map.Internal ( -- * Query , null , size + , sizeAtMost , compareSize , member , notMember @@ -533,6 +534,10 @@ size = go 0 go acc (Tip _ _) = 1 + acc go acc Nil = acc +-- | Check if the map is <= n in O(min(|map|,n)) +sizeAtMost :: Word64Map a -> Int -> Bool +sizeAtMost map n = compareSize map n /= GT + -- | $O(\min(n,c))$. Compare the number of entries in the map to an @Int@. -- -- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is ===================================== compiler/GHC/Data/Word64Map/Lazy.hs ===================================== @@ -113,6 +113,7 @@ module GHC.Data.Word64Map.Lazy ( -- ** Size , WM.null , size + , sizeAtMost , compareSize -- * Combine ===================================== compiler/GHC/Data/Word64Map/Strict.hs ===================================== @@ -130,6 +130,7 @@ module GHC.Data.Word64Map.Strict ( -- ** Size , null , size + , sizeAtMost , compareSize -- * Combine ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -132,6 +132,7 @@ module GHC.Data.Word64Map.Strict.Internal ( -- ** Size , null , size + , sizeAtMost , compareSize -- * Combine @@ -324,6 +325,7 @@ import GHC.Data.Word64Map.Internal , spanAntitone , restrictKeys , size + , sizeAtMost , compareSize , split , splitLookup ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -351,8 +351,8 @@ foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldUDFM #-} -- Specialises k and z into M.foldr on the small-map path. foldUDFM k z (UDFM m ub) - | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m - | otherwise = fold_udfm k z m ub + | M.sizeAtMost m 1 = M.foldr (k . taggedFst) z m + | otherwise = fold_udfm k z m ub fold_udfm :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a {-# NOINLINE fold_udfm #-} @@ -402,8 +402,8 @@ eltsUDFM :: UniqDFM key elt -> [elt] {-# INLINE eltsUDFM #-} -- so the small case is a good producer -- This matters for T13719. eltsUDFM (UDFM m ub) - | M.compareSize m 1 /= GT = build (\c n -> M.foldr (c . taggedFst) n m) - | otherwise = elts_udfm m ub + | M.sizeAtMost m 1 = build (\c n -> M.foldr (c . taggedFst) n m) + | otherwise = elts_udfm m ub elts_udfm :: M.Word64Map (TaggedVal elt) -> Int -> [elt] {-# NOINLINE elts_udfm #-} @@ -511,7 +511,7 @@ udfmToList :: UniqDFM key elt -> [(Unique, elt)] -- traverseUSDFM in the pattern-match checker, which doesn't fuse. Inlining -- the size dispatch into it regresses T17836. udfmToList (UDFM m ub) - | M.compareSize m 1 /= GT = + | M.sizeAtMost m 1 = M.foldrWithKey (\k tv r -> (mkUniqueGrimily k, taggedFst tv) : r) [] m | usePigeonholeSort m ub = pigeonholeSort ub (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/574c875f0701e8cc86511cd5df63262… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/574c875f0701e8cc86511cd5df63262… 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] testsuite: Use sigkill in process009.
by Marge Bot (＠marge-bot) 18 Aug '26

18 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fed942ac by Andreas Klebinger at 2026-08-17T12:11:57-04:00 testsuite: Use sigkill in process009. SIGHUB might have been blocked by a (grand)*parent of the test. In such cases the test would fail as the python process would simply exist gracefully instead of committing to a premature end. By using SIGKILL we can rely on the signal not being blocked, fixing #27578 in the process. - - - - - 2 changed files: - testsuite/tests/process/process009.hs - testsuite/tests/process/process009.stdout Changes: ===================================== testsuite/tests/process/process009.hs ===================================== @@ -11,7 +11,7 @@ main = do let script = intercalate " " [ "exec python3 2>/dev/null" , "-c" - , "'import os; os.kill(os.getpid(), 1)'" + , "'import os; os.kill(os.getpid(), 9)'" -- SIGKILL ] (_,_,_,p) <- createProcess (shell script) waitForProcess p >>= print ===================================== testsuite/tests/process/process009.stdout ===================================== @@ -1,3 +1,3 @@ -ExitFailure (-1) -Just (ExitFailure (-1)) -Just (ExitFailure (-1)) +ExitFailure (-9) +Just (ExitFailure (-9)) +Just (ExitFailure (-9)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fed942ac50666b18232b5670752858a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fed942ac50666b18232b5670752858a… 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/sjakobi/stack-hadrian-build-full-ci
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed new branch wip/sjakobi/stack-hadrian-build-full-ci at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/stack-hadrian-build-f… 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/sjakobi/T27619-liveness-fixpoint-formats] NCG: compare register formats by width, remove Ord Format
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: d318cfdb by Simon Jakobi at 2026-08-17T17:28:14+02:00 NCG: compare register formats by width, remove Ord Format maxRegWithFormat, minusCoveredRegs and the caller-less shrinkingRegs compared formats with Format's derived Ord, which orders by constructor, not by width: VecFormat 16 FmtInt8 (16 bytes) sorts above VecFormat 8 FmtDouble (64 bytes). This is harmless while all vector vregs are 128-bit, but once wider vectors land in the NCG it becomes unsound in both directions of Note [Register formats in liveness analysis]: the maxRegWithFormat join could record a live format narrower than a read, violating (FmtBwd1), and minusCoveredRegs could treat a narrow vector write as covering a wider live format, violating (FmtBwd2). Noted in #27619. The comparisons now go by formatToWidth, except the liveness join maxRegWithFormat, which needs a total order to keep the liveness fixpoint convergent and uses the new width-major compareFormat. See Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. Also remove the Ord instances of Format and ScalarFormat, so future users need to make a conscious choice between formatToWidth and compareFormat. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -23,6 +23,7 @@ module GHC.CmmToAsm.Format ( vecFormat, isVecFormat, cmmTypeFormat, + compareFormat, formatToWidth, scalarWidth, formatInBytes, @@ -40,11 +41,13 @@ where import GHC.Prelude +import Data.Semigroup ( (<>) ) + import GHC.Cmm import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) import GHC.Types.Unique ( Uniquable(..) ) import GHC.Types.Unique.Set -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic {- Note [GHC's data format representations] @@ -92,7 +95,9 @@ data Format | FF64 | VecFormat !Length -- ^ number of elements (always at least 2) !ScalarFormat -- ^ format of each element - deriving (Show, Eq, Ord) + deriving (Show, Eq) + -- No Ord: compare via 'formatToWidth', or use 'compareFormat' where a + -- total order is needed. pattern IntegerFormat :: Format pattern IntegerFormat <- ( isIntegerFormat -> True ) @@ -117,7 +122,7 @@ data ScalarFormat | FmtInt64 | FmtFloat | FmtDouble - deriving (Show, Eq, Ord) + deriving (Show, Eq) scalarFormatFormat :: ScalarFormat -> Format scalarFormatFormat = \case @@ -248,6 +253,33 @@ scalarWidth = \case formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth +-- | Total order on formats: by width, with an arbitrary but fixed tiebreak +-- between distinct formats of the same width. +-- +-- See Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. +compareFormat :: Format -> Format -> Ordering +compareFormat f1 f2 = + compare (formatToWidth f1) (formatToWidth f2) <> compare (tag f1) (tag f2) + where + tag :: Format -> (Int, Length) + tag = \case + II8 -> (0, 0) + II16 -> (1, 0) + II32 -> (2, 0) + II64 -> (3, 0) + FF32 -> (4, 0) + FF64 -> (5, 0) + VecFormat l s -> (6 + scalarTag s, l) + + scalarTag :: ScalarFormat -> Int + scalarTag = \case + FmtInt8 -> 0 + FmtInt16 -> 1 + FmtInt32 -> 2 + FmtInt64 -> 3 + FmtFloat -> 4 + FmtDouble -> 5 + -------------------------------------------------------------------------------- -- | A typed virtual register: a virtual register, together with the specific ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -484,7 +484,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) , src < tgt = do let format = cmmTypeFormat pk -- lwa is DS-form. See Note [Power instruction format] - let form = if format >= II32 then DS else D + let form = if formatToWidth format >= W32 then DS else D Amode addr addr_code <- getAmode form mem let code dst = assert (format == intFormat src) $ addr_code `snocOL` LA format dst addr ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -937,9 +937,9 @@ test: dependency order. Comparing the whole accumulated block map would make the fixpoint quadratic in procedure size (#27437). -The fixpoint terminates because the entries can only grow: registers are -only added, formats only increase via 'maxRegWithFormat' joins, and both -lattices are finite. +To ensure termination, 'maxRegWithFormat' uses 'compareFormat' which defines a +total order on formats. Comparing the widths only would introduce the risk of +an infinite loop where each iteration swaps two formats of the same width. -} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -20,7 +20,8 @@ module GHC.CmmToAsm.Reg.Regs ( import GHC.Prelude import GHC.Platform.Reg ( Reg ) -import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat, + compareFormat, formatToWidth ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) @@ -39,11 +40,12 @@ newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - = if fmt1 >= fmt2 - then r1 - else r2 - -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', - -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + | LT <- compareFormat fmt1 fmt2 = r2 + | otherwise = r1 + -- See Note [Convergence of the liveness fixpoint] in + -- GHC.CmmToAsm.Reg.Liveness. + -- + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat'. noRegs :: Regs noRegs = Regs emptyUniqSet @@ -66,7 +68,7 @@ minusCoveredRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = - if fmt2 >= fmt1 + if formatToWidth fmt2 >= formatToWidth fmt1 || not ( isVecFormat fmt1 ) -- See Wrinkle [Don't allow scalar partial writes] @@ -99,7 +101,7 @@ shrinkingRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - | fmt2 < fmt1 + | formatToWidth fmt2 < formatToWidth fmt1 = Just r2 | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d318cfdba333b3bed875a917ab86348… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d318cfdba333b3bed875a917ab86348… 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/sjakobi/T27368] Cmm: only treat continuations of reachable calls as proc points
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27368 at Glasgow Haskell Compiler / GHC Commits: 81d557a0 by Simon Jakobi at 2026-08-17T16:53:11+02:00 Cmm: only treat continuations of reachable calls as proc points callProcPoints used to fold over the whole block map, which can contain unreachable blocks: the control-flow optimiser and the common block eliminator both leave them behind (see Note [unreachable blocks]). In particular, when the common block eliminator merges duplicated call blocks over several iterations, the chained label substitution can leave the continuation of a losing copy unreachable. callProcPoints still collected that continuation and attachContInfoTables attached an info table to it, but stack layout walks only reachable blocks and produced no stack map for it, so setInfoTableStackMap panicked. Fix: make callProcPoints fold over revPostorder, i.e. reachable blocks only. Also: * Rewrite Note [unreachable blocks] to state the invariant. * Give elimCommonBlocks a haddock (absorbing the module's intro comment) that documents its unreachable-block behaviour, and drop the stale claim that ContFlowOpt had already removed unreachable blocks. The regression test distills the code shape that triggered the panic when compiling GHC.CmmToAsm.Dwarf.Types with -O2 on top of !16168. Fixes #27368 Assisted-by: Claude Fable 5 - - - - - 6 changed files: - + changelog.d/27368 - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/ProcPoint.hs - + testsuite/tests/codeGen/should_compile/T27368.hs - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== changelog.d/27368 ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Fix a ``setInfoTableStackMap`` panic caused by calls in unreachable Cmm blocks. +issues: #27368 +mrs: !16169 ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -30,20 +30,23 @@ import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE --- ----------------------------------------------------------------------------- --- Eliminate common blocks - +-- | Merge identical blocks +-- -- If two blocks are identical except for the label on the first node, -- then we can eliminate one of the blocks. To ensure that the semantics -- of the program are preserved, we have to rewrite each predecessor of the -- eliminated block to proceed with the block we keep. - +-- +-- Tolerates unreachable blocks in its input, and produces them: the +-- losing copy of a merged pair stays in the block map, now +-- unreachable. See Note [unreachable blocks] in GHC.Cmm.Pipeline. +-- -- The algorithm iterates over the blocks in the graph, -- checking whether it has seen another block that is equal modulo labels. -- If so, then it adds an entry in a map indicating that the new block -- is made redundant by the old block. -- Otherwise, it is added to the useful blocks. - +-- -- To avoid comparing every block with every other block repeatedly, we group -- them by -- * a hash of the block, ignoring labels (explained below) @@ -57,16 +60,13 @@ import qualified Data.List.NonEmpty as NE -- All in all, two blocks should never be compared if they have different -- hashes, and at most once otherwise. Previously, we were slower, and people -- rightfully complained: #10397 - --- TODO: Use optimization fuel elimCommonBlocks :: CmmGraph -> CmmGraph +-- TODO: Use optimization fuel elimCommonBlocks g = replaceLabels env $ copyTicks env g where env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. + -- Block order doesn't matter here, so we use toBlockList, + -- which is faster than revPostorder. groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -353,10 +353,19 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] ~~~~~~~~~~~~~~~~~~~~~~~~~ -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. +The control-flow optimiser and the common block eliminator sometimes +leave unreachable blocks behind. Some later passes drop them, as a +side effect of rebuilding the graph from a reachability traversal, +but only the removeUnreachableBlocksProc pass at the end of the +pipeline guarantees a graph free of them. So every pass must +tolerate unreachable blocks in its input, and must not let them +influence the reachable part of the graph. + +In particular, callProcPoints in GHC.Cmm.ProcPoint must only consider +reachable blocks: the continuation of a call in an unreachable +block may itself be unreachable, and must not become a proc point. +Otherwise attachContInfoTables would attach an info table to it, +resulting in a setInfoTableStackMap panic (#27368). To make unreachable blocks visible in -ddump-cmm-* output, add -dppr-debug. -} ===================================== compiler/GHC/Cmm/ProcPoint.hs ===================================== @@ -173,8 +173,12 @@ procPointLattice = DataflowLattice unreached add_to -- introduced because they're reachable from multiple proc points. -- -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +-- +-- Fold over reachable blocks only: the continuation of an unreachable +-- call must not become a proc point. See Note [unreachable blocks] +-- in GHC.Cmm.Pipeline. callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g +callProcPoints g = foldl' add (setSingleton (g_entry g)) (revPostorder g) where add :: LabelSet -> CmmBlock -> LabelSet add set b = case lastNode b of CmmCall {cml_cont = Just k} -> setInsert k set ===================================== testsuite/tests/codeGen/should_compile/T27368.hs ===================================== @@ -0,0 +1,22 @@ +-- Regression test for #27368: setInfoTableStackMap panicked because +-- callProcPoints collected the continuation of a call in an unreachable +-- block. The two branches below have identical suffixes from the inner +-- case onwards. Common block elimination merges the duplicated call +-- blocks, leaving the losing copies in the block map. Since +-- replaceLabels does not resolve the resulting substitution chains, one +-- dead call ends up returning to a label that no reachable block +-- mentions. +module T27368 (f) where + +{-# NOINLINE put #-} +put :: Int -> Int -> IO () +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure () + +data T = N | J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + put h 0 ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T27368', normal, compile, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81d557a0c4e4621bd5d9ea8d85a4e56… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81d557a0c4e4621bd5d9ea8d85a4e56… 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/jeltsch/improve-closure-property-check
by Wolfgang Jeltsch (＠jeltsch) 17 Aug '26

17 Aug '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/improve-closure-prope… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/ci-stages] fixup! ci: build and test stage
by Magnus (＠MangoIV) 17 Aug '26

17 Aug '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 1e8d4d42 by mangoiv at 2026-08-17T16:28:28+02:00 fixup! ci: build and test stage - - - - - 1 changed file: - .gitlab/ci.sh Changes: ===================================== .gitlab/ci.sh ===================================== @@ -697,9 +697,9 @@ function test_hadrian() { return # 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" - local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" - install_bindist $dist_dir/ghc-*/ "$instdir" + # local instdir="$TOP/_build/install" + local test_compiler="$dist_dir/bin/${cross_prefix}ghc$exe" + # install_bindist $dist_dir/ghc-*/ "$instdir" echo 'main = putStrLn "hello world"' > expected run "$test_compiler" -package ghc "$TOP/.gitlab/hello.hs" -o hello @@ -731,9 +731,9 @@ function test_hadrian() { "runtest.opts+=--unexpected-output-dir=$TOP/unexpected-test-output" \ || fail "hadrian cabal-install test" else - local instdir="$TOP/_build/install" - local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" - install_bindist $dist_dir/ghc-*/ "$instdir" + # local instdir="$TOP/_build/install" + local test_compiler="$dist_dir/bin/${cross_prefix}ghc$exe" + # install_bindist $dist_dir/ghc-*/ "$instdir" # if [[ "${CI_JOB_NAME}" != *"windows"* ]] && [ -z "${CROSS_TARGET:-}" ] # then View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e8d4d426981da8042afabaf69a4275… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e8d4d426981da8042afabaf69a4275… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/jeltsch/textual-bytecode-output
by Wolfgang Jeltsch (＠jeltsch) 17 Aug '26

17 Aug '26

Wolfgang Jeltsch deleted branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27368] Cmm: only treat continuations of reachable calls as proc points
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27368 at Glasgow Haskell Compiler / GHC Commits: 47985b11 by Simon Jakobi at 2026-08-17T14:45:24+02:00 Cmm: only treat continuations of reachable calls as proc points callProcPoints used to fold over the whole block map, which can contain unreachable blocks: the control-flow optimiser and the common block eliminator both leave them behind, and they are only removed at the end of the Cmm pipeline (Note [unreachable blocks]). In particular, when the common block eliminator merges duplicated call blocks it leaves the losing copy in the block map, and the continuation of such a dead call can itself be unreachable. callProcPoints would still collect that continuation, attachContInfoTables would attach an info table to it, but stack layout (which only walks reachable blocks) produced no stack map for it, so setInfoTableStackMap panicked. Fix: make callProcPoints fold over revPostorder, i.e. reachable blocks only. Also: * Rewrite Note [unreachable blocks] to state the invariant. * Give elimCommonBlocks a haddock (absorbing the module's intro comment) that documents its unreachable-block behaviour, and drop the stale claim that ContFlowOpt had already removed unreachable blocks. The regression test distills the code shape that triggered the panic when compiling GHC.CmmToAsm.Dwarf.Types with -O2 on top of !16168. Fixes #27368 Assisted-by: Claude Fable 5 - - - - - 6 changed files: - + changelog.d/27368 - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/ProcPoint.hs - + testsuite/tests/codeGen/should_compile/T27368.hs - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== changelog.d/27368 ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Fix a ``setInfoTableStackMap`` panic caused by calls in unreachable Cmm blocks. +issues: #27368 +mrs: !16169 ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -30,20 +30,23 @@ import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE --- ----------------------------------------------------------------------------- --- Eliminate common blocks - +-- | Merge identical blocks +-- -- If two blocks are identical except for the label on the first node, -- then we can eliminate one of the blocks. To ensure that the semantics -- of the program are preserved, we have to rewrite each predecessor of the -- eliminated block to proceed with the block we keep. - +-- +-- Tolerates unreachable blocks in its input, and produces them: the +-- losing copy of a merged pair stays in the block map, now +-- unreachable. See Note [unreachable blocks] in GHC.Cmm.Pipeline. +-- -- The algorithm iterates over the blocks in the graph, -- checking whether it has seen another block that is equal modulo labels. -- If so, then it adds an entry in a map indicating that the new block -- is made redundant by the old block. -- Otherwise, it is added to the useful blocks. - +-- -- To avoid comparing every block with every other block repeatedly, we group -- them by -- * a hash of the block, ignoring labels (explained below) @@ -57,16 +60,13 @@ import qualified Data.List.NonEmpty as NE -- All in all, two blocks should never be compared if they have different -- hashes, and at most once otherwise. Previously, we were slower, and people -- rightfully complained: #10397 - --- TODO: Use optimization fuel elimCommonBlocks :: CmmGraph -> CmmGraph +-- TODO: Use optimization fuel elimCommonBlocks g = replaceLabels env $ copyTicks env g where env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. + -- Block order doesn't matter here, so we use toBlockList, + -- which is faster than revPostorder. groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -353,10 +353,18 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] ~~~~~~~~~~~~~~~~~~~~~~~~~ -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. +The control-flow optimiser and the common block eliminator sometimes +leave unreachable blocks behind. They are removed only here, at the +end of the pipeline, to save the cost of extra reachability passes — +so every pass in between runs on a block map that may contain +unreachable blocks, and must not let them influence the reachable +part of the graph. + +In particular, callProcPoints in GHC.Cmm.ProcPoint must only consider +reachable blocks: the continuation of a call in an unreachable +block may itself be unreachable, and must not become a proc point. +Otherwise attachContInfoTables would attach an info table to it, +resulting in a setInfoTableStackMap panic (#27368). To make unreachable blocks visible in -ddump-cmm-* output, add -dppr-debug. -} ===================================== compiler/GHC/Cmm/ProcPoint.hs ===================================== @@ -173,8 +173,12 @@ procPointLattice = DataflowLattice unreached add_to -- introduced because they're reachable from multiple proc points. -- -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +-- +-- Fold over reachable blocks only: the continuation of an unreachable +-- call must not become a proc point. See Note [unreachable blocks] +-- in GHC.Cmm.Pipeline. callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g +callProcPoints g = foldl' add (setSingleton (g_entry g)) (revPostorder g) where add :: LabelSet -> CmmBlock -> LabelSet add set b = case lastNode b of CmmCall {cml_cont = Just k} -> setInsert k set ===================================== testsuite/tests/codeGen/should_compile/T27368.hs ===================================== @@ -0,0 +1,20 @@ +-- Regression test for #27368: setInfoTableStackMap panicked because +-- callProcPoints collected the continuation of a call in an unreachable +-- block. The two branches below have identical suffixes from the inner +-- case onwards; common block elimination merges the duplicated call +-- blocks but leaves the losing copies in the block map, where the dead +-- call's continuation label is itself unreachable. +module T27368 (f) where + +{-# NOINLINE put #-} +put :: Int -> Int -> IO () +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure () + +data T = N | J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + put h 0 ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T27368', normal, compile, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47985b111483e8b577800676efa3949… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47985b111483e8b577800676efa3949… 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