[Git][ghc/ghc][wip/TTG-No-Orphans] First pass of orphan instance removal.
by recursion-ninja (＠recursion-ninja) 17 Jul '26
by recursion-ninja (＠recursion-ninja) 17 Jul '26
17 Jul '26
recursion-ninja pushed to branch wip/TTG-No-Orphans at Glasgow Haskell Compiler / GHC
Commits:
bff295f2 by Recursion Ninja at 2026-07-17T14:03:56-04:00
First pass of orphan instance removal.
This is part of a technical debt removal effort made possible
now that seperating out the AST via TTG comes to a close.
As the AST in 'L.H.S' has been incrementally separated from the GHC internals,
there are many accumulated orphan instance of 'Binary', 'Outputable', 'Uniquable', etc.
The orphan instance of data-types from within 'L.H.S' are having thier orphan
instances moved to the module which defined the type-class; i.e. moving an orphan
'Binary' instance to 'GHC.Utils.Binary'.
Orphan instances resolved (37):
| Data-type | Resolved instance(s) | Former orphan module(s) |
| -------------------- | -------------------------- | ------------------------- |
| Role | Binary, NFData, Outputable | GHC.Core.Coercion.Axiom |
| SrcStrictness | Binary, NFData, Outputable | GHC.Core.DataCon |
| SrcUnpackedness | Binary, NFData, Outputable | GHC.Core.DataCon |
| Fixity | Binary, Outputable | GHC.Hs.Basic |
| FixityDirection | Binary, Outputable | GHC.Hs.Basic |
| LexicalFixity | Outputable | GHC.Hs.Basic |
| CCallTarget | NFData | GHC.Hs.Decls.Foreign |
| CType | NFData | GHC.Hs.Decls.Foreign |
| Header | NFData | GHC.Hs.Decls.Foreign |
| OverlapMode | Binary, NFData | GHC.Hs.Decls.Overlap |
| WithHsDocIdentifiers | NFData, Outputable | GHC.Hs.Doc |
| HsDocString | NFData | GHC.Hs.DocString |
| HsDocStringChunk | Binary, Outputable | GHC.Hs.DocString |
| HsDocStringDecorator | Binary, Outputable | GHC.Hs.DocString |
| NamespaceSpecifier | Outputable | GHC.Hs.ImpExp |
| ForAllTyFlag | Binary, NFData, Outputable | GHC.Hs.Specificity |
| Specificity | Binary, NFData | GHC.Hs.Specificity |
| PromotionFlag | Binary, Outputable | GHC.Types.Basic |
| FieldLabelString | Outputable, Uniquable | GHC.Types.FieldLabel |
| InlinePragma | Binary | GHC.Types.InlinePragma |
-------------------------
Metric Decrease:
hard_hole_fits
-------------------------
Closes #21262, #27469
- - - - -
26 changed files:
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Hs/ImpExp.hs
- − compiler/GHC/Hs/Specificity.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Fixity.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Types/InlinePragma.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Doc.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Specificity.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
-
-- (c) The University of Glasgow 2012
-- | Module for coercion axioms, used to represent type family instances
@@ -22,7 +20,7 @@ module GHC.Core.Coercion.Axiom (
coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
placeHolderIncomps,
- Role(..), fsFromRole,
+ Role(..),
CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn,
coAxiomRuleArgRoles, coAxiomRuleRole,
@@ -43,7 +41,6 @@ import GHC.Types.Name
import GHC.Types.Unique
import GHC.Types.Var
import GHC.Utils.Misc
-import GHC.Utils.Binary
import GHC.Utils.Panic
import GHC.Data.Pair
import GHC.Types.Basic
@@ -52,7 +49,6 @@ import GHC.Types.SrcLoc
import qualified Data.Data as Data
import Data.Array
import Data.List ( mapAccumL )
-import Control.DeepSeq
{-
Note [Coercion axiom branches]
@@ -521,44 +517,6 @@ instance Outputable CoAxBranch where
, ppUnless (null incomps) $
text "incomps:" <+> vcat (map ppr incomps) ])
-{-
-************************************************************************
-* *
- Roles
-* *
-************************************************************************
-
-Roles are defined here to avoid circular dependencies.
--}
-
--- These names are slurped into the parser code. Changing these strings
--- will change the **surface syntax** that GHC accepts! If you want to
--- change only the pretty-printing, do some replumbing. See
--- mkRoleAnnotDecl in GHC.Parser.PostProcess
-fsFromRole :: Role -> FastString
-fsFromRole Nominal = fsLit "nominal"
-fsFromRole Representational = fsLit "representational"
-fsFromRole Phantom = fsLit "phantom"
-
-instance Outputable Role where
- ppr = ftext . fsFromRole
-
-instance Binary Role where
- put_ bh Nominal = putByte bh 1
- put_ bh Representational = putByte bh 2
- put_ bh Phantom = putByte bh 3
-
- get bh = do tag <- getByte bh
- case tag of 1 -> return Nominal
- 2 -> return Representational
- 3 -> return Phantom
- _ -> panic ("get Role " ++ show tag)
-
-instance NFData Role where
- rnf Nominal = ()
- rnf Representational = ()
- rnf Phantom = ()
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -5,8 +5,6 @@
\section[DataCon]{@DataCon@: Data Constructors}
-}
-{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary
-
module GHC.Core.DataCon (
-- * Main data types
DataCon, DataConRep(..),
@@ -109,7 +107,6 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Data as Data
import Data.Char
import Data.List( find )
-import Control.DeepSeq
{-
Note [Data constructor representation]
@@ -1030,16 +1027,6 @@ instance Outputable HsImplBang where
ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co)
ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b)
-instance Outputable SrcStrictness where
- ppr SrcLazy = char '~'
- ppr SrcStrict = char '!'
- ppr NoSrcStrict = empty
-
-instance Outputable SrcUnpackedness where
- ppr SrcUnpack = text "{-# UNPACK #-}"
- ppr SrcNoUnpack = text "{-# NOUNPACK #-}"
- ppr NoSrcUnpack = empty
-
instance Outputable StrictnessMark where
ppr MarkedStrict = text "!"
ppr NotMarkedStrict = empty
@@ -1054,40 +1041,6 @@ instance Binary StrictnessMark where
1 -> return MarkedStrict
_ -> panic "Invalid binary format"
-instance Binary SrcStrictness where
- put_ bh SrcLazy = putByte bh 0
- put_ bh SrcStrict = putByte bh 1
- put_ bh NoSrcStrict = putByte bh 2
-
- get bh =
- do h <- getByte bh
- case h of
- 0 -> return SrcLazy
- 1 -> return SrcStrict
- _ -> return NoSrcStrict
-
-instance Binary SrcUnpackedness where
- put_ bh SrcNoUnpack = putByte bh 0
- put_ bh SrcUnpack = putByte bh 1
- put_ bh NoSrcUnpack = putByte bh 2
-
- get bh =
- do h <- getByte bh
- case h of
- 0 -> return SrcNoUnpack
- 1 -> return SrcUnpack
- _ -> return NoSrcUnpack
-
-instance NFData SrcStrictness where
- rnf SrcLazy = ()
- rnf SrcStrict = ()
- rnf NoSrcStrict = ()
-
-instance NFData SrcUnpackedness where
- rnf SrcNoUnpack = ()
- rnf SrcUnpack = ()
- rnf NoSrcUnpack = ()
-
-- | Compare strictness annotations
eqHsBang :: HsImplBang -> HsImplBang -> Bool
eqHsBang HsLazy HsLazy = True
=====================================
compiler/GHC/Hs/Basic.hs
=====================================
@@ -1,52 +1,6 @@
-{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary
-{-# LANGUAGE TypeFamilies #-}
-
-- | Fixity
module GHC.Hs.Basic
( module Language.Haskell.Syntax.Basic
) where
-import GHC.Prelude
-
-import GHC.Utils.Outputable
-import GHC.Utils.Binary
-
import Language.Haskell.Syntax.Basic
-
-instance Outputable LexicalFixity where
- ppr Prefix = text "Prefix"
- ppr Infix = text "Infix"
-
-instance Outputable FixityDirection where
- ppr InfixL = text "infixl"
- ppr InfixR = text "infixr"
- ppr InfixN = text "infix"
-
-instance Outputable Fixity where
- ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
-
-
-instance Binary Fixity where
- put_ bh (Fixity aa ab) = do
- put_ bh aa
- put_ bh ab
- get bh = do
- aa <- get bh
- ab <- get bh
- return (Fixity aa ab)
-
-------------------------
-
-instance Binary FixityDirection where
- put_ bh InfixL =
- putByte bh 0
- put_ bh InfixR =
- putByte bh 1
- put_ bh InfixN =
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return InfixL
- 1 -> return InfixR
- _ -> return InfixN
=====================================
compiler/GHC/Hs/Decls/Overlap.hs
=====================================
@@ -1,12 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{- Necessary for the following instances:
- * (type class): Binary OverlapMode
- * (type class): NFData OverlapMode
--}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- XOverlapMode, XXOverlapMode
{- |
Data-types describing the overlap annotations for instances as well as
@@ -74,34 +69,6 @@ type instance XOverlapMode (GhcPass _) = SourceText
type instance XXOverlapMode (GhcPass _) = DataConCantHappen
-instance NFData (OverlapMode (GhcPass p)) where
- rnf = \case
- NoOverlap s -> rnf s
- Overlappable s -> rnf s
- Overlapping s -> rnf s
- Overlaps s -> rnf s
- Incoherent s -> rnf s
- NonCanonical s -> rnf s
-
-instance Binary (OverlapMode (GhcPass p)) where
- put_ bh = \case
- NoOverlap s -> putByte bh 0 >> put_ bh s
- Overlaps s -> putByte bh 1 >> put_ bh s
- Incoherent s -> putByte bh 2 >> put_ bh s
- Overlapping s -> putByte bh 3 >> put_ bh s
- Overlappable s -> putByte bh 4 >> put_ bh s
- NonCanonical s -> putByte bh 5 >> put_ bh s
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> get bh >>= \s -> return $ NoOverlap s
- 1 -> get bh >>= \s -> return $ Overlaps s
- 2 -> get bh >>= \s -> return $ Incoherent s
- 3 -> get bh >>= \s -> return $ Overlapping s
- 4 -> get bh >>= \s -> return $ Overlappable s
- _ -> get bh >>= \s -> return $ NonCanonical s
-
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = text "[safe]"
pprSafeOverlap False = empty
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -63,16 +63,6 @@ type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass p
deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass)
deriving instance (Eq (LIdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)
-instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
- rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i)
-
--- | For compatibility with the existing @-ddump-parsed' output, we only show
--- the docstring.
---
--- Use 'pprHsDoc' to show `HsDoc`'s internals.
-instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
- ppr (WithHsDocIdentifiers s _ids) = ppr s
-
instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
put_ bh (WithHsDocIdentifiers s ids) = do
put_ bh s
=====================================
compiler/GHC/Hs/DocString.hs
=====================================
@@ -5,6 +5,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+-- Binary HsDocString
+-- Outputable HsDocString
module GHC.Hs.DocString
( LHsDocString
@@ -44,7 +46,6 @@ import GHC.Hs.Extension.Pass (GhcPass, GhcPs, GhcRn, GhcTc)
import Language.Haskell.Syntax.Doc
import Language.Haskell.Syntax.Extension
-import Control.DeepSeq
import Data.Data
import Data.List.NonEmpty (NonEmpty(..))
import Data.List (intercalate)
@@ -82,11 +83,6 @@ instance (Show (LHsDocStringChunk pass), XXHsDocString pass ~ DataConCantHappen)
instance Outputable (HsDocString (GhcPass p)) where
ppr = text . renderHsDocString
-instance NFData (HsDocString (GhcPass p)) where
- rnf (MultiLineDocString _ a b) = rnf a `seq` rnf b
- rnf (NestedDocString _ a b) = rnf a `seq` rnf b
- rnf (GeneratedDocString _ a) = rnf a
-
-- | Annotate a pretty printed thing with its doc.
-- The docstring comes after if it is 'HsDocStringPrevious'.
-- Otherwise it comes before.
@@ -120,37 +116,12 @@ instance Binary (HsDocString (GhcPass p)) where
2 -> GeneratedDocString noExtField <$> get bh
t -> fail $ "HsDocString: invalid tag " ++ show t
-instance Outputable HsDocStringDecorator where
- ppr = text . printDecorator
-
printDecorator :: HsDocStringDecorator -> String
printDecorator HsDocStringNext = "|"
printDecorator HsDocStringPrevious = "^"
printDecorator (HsDocStringNamed n) = '$':n
printDecorator (HsDocStringGroup n) = replicate n '*'
-instance Binary HsDocStringDecorator where
- put_ bh x = case x of
- HsDocStringNext -> putByte bh 0
- HsDocStringPrevious -> putByte bh 1
- HsDocStringNamed n -> putByte bh 2 >> put_ bh n
- HsDocStringGroup n -> putByte bh 3 >> put_ bh n
- get bh = do
- tag <- getByte bh
- case tag of
- 0 -> pure HsDocStringNext
- 1 -> pure HsDocStringPrevious
- 2 -> HsDocStringNamed <$> get bh
- 3 -> HsDocStringGroup <$> get bh
- t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
-
-instance Binary HsDocStringChunk where
- put_ bh (HsDocStringChunk bs) = put_ bh bs
- get bh = HsDocStringChunk <$> get bh
-
-instance Outputable HsDocStringChunk where
- ppr = text . unpackHDSC
-
mkGeneratedHsDocStringGhc :: String -> HsDocString (GhcPass p)
mkGeneratedHsDocStringGhc = mkGeneratedHsDocString noExtField . mkHsDocStringChunk
=====================================
compiler/GHC/Hs/ImpExp.hs
=====================================
@@ -447,8 +447,3 @@ coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace
filterByNamespaceSpecifierGREs :: NamespaceSpecifier (GhcPass p) -> [GlobalRdrElt] -> [GlobalRdrElt]
filterByNamespaceSpecifierGREs NoNamespaceSpecifier{} = id
filterByNamespaceSpecifierGREs ns_spec = filterByNamespaceGREs (coveredByNamespaceSpecifier ns_spec)
-
-instance Outputable (NamespaceSpecifier (GhcPass p)) where
- ppr NoNamespaceSpecifier{} = empty
- ppr TypeNamespaceSpecifier{} = text "type"
- ppr DataNamespaceSpecifier{} = text "data"
=====================================
compiler/GHC/Hs/Specificity.hs deleted
=====================================
@@ -1,51 +0,0 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-module GHC.Hs.Specificity where
-
-import Prelude
-import Control.DeepSeq (NFData(..))
-
-import GHC.Utils.Outputable
-import GHC.Utils.Binary
-
-import Language.Haskell.Syntax.Specificity
-
-{- *********************************************************************
-* *
-* ForAllTyFlag
-* *
-********************************************************************* -}
-
-instance Outputable ForAllTyFlag where
- ppr Required = text "[req]"
- ppr Specified = text "[spec]"
- ppr Inferred = text "[infrd]"
-
-instance Binary Specificity where
- put_ bh SpecifiedSpec = putByte bh 0
- put_ bh InferredSpec = putByte bh 1
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return SpecifiedSpec
- _ -> return InferredSpec
-
-instance Binary ForAllTyFlag where
- put_ bh Required = putByte bh 0
- put_ bh Specified = putByte bh 1
- put_ bh Inferred = putByte bh 2
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return Required
- 1 -> return Specified
- _ -> return Inferred
-
-instance NFData Specificity where
- rnf SpecifiedSpec = ()
- rnf InferredSpec = ()
-instance NFData ForAllTyFlag where
- rnf (Invisible spec) = rnf spec
- rnf Required = ()
-
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -136,7 +136,6 @@ import GHC.Hs -- Lots of it
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName )
import GHC.Core.ConLike ( ConLike(..) )
-import GHC.Core.Coercion.Axiom ( fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Basic
@@ -424,7 +423,7 @@ mkRoleAnnotDecl loc tycon roles anns
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
- possible_roles = [(fsFromRole role, role) | role <- all_roles]
+ possible_roles = [(strFromRole role, role) | role <- all_roles]
parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing
parse_role (L loc_role (Just role))
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -14,14 +14,6 @@ types that
\end{itemize}
-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-
-Above flag is necessary for these instances:
- * Binary Boxity
- * Binary PromotionFlag
- * Outputable Boxity
- * Outputable PromotionFlag
--}
{-# LANGUAGE DerivingVia #-}
module GHC.Types.Basic (
@@ -377,27 +369,6 @@ unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
-{- *********************************************************************
-* *
- Promotion flag
-* *
-********************************************************************* -}
-
-instance Outputable PromotionFlag where
- ppr NotPromoted = text "NotPromoted"
- ppr IsPromoted = text "IsPromoted"
-
-instance Binary PromotionFlag where
- put_ bh NotPromoted = putByte bh 0
- put_ bh IsPromoted = putByte bh 1
-
- get bh = do
- n <- getByte bh
- case n of
- 0 -> return NotPromoted
- 1 -> return IsPromoted
- _ -> fail "Binary(IsPromoted): fail)"
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString
{-
%
@@ -48,7 +47,6 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Types.Name
-import GHC.Types.Unique (Uniquable(..))
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Data.FastString
@@ -89,12 +87,6 @@ instance Outputable FieldLabel where
<> ppr (flHasDuplicateRecordFields fl)
<> ppr (flHasFieldSelector fl))
-instance Outputable FieldLabelString where
- ppr (FieldLabelString l) = ppr l
-
-instance Uniquable FieldLabelString where
- getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs)
-
-- | Flag to indicate whether the DuplicateRecordFields extension is enabled.
data DuplicateRecordFields
= DuplicateRecordFields -- ^ Fields may be duplicated in a single module
=====================================
compiler/GHC/Types/Fixity.hs
=====================================
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances
-
-- | Fixity
module GHC.Types.Fixity
( Fixity (..)
@@ -11,14 +9,12 @@ module GHC.Types.Fixity
, negateFixity
, funTyFixity
, compareFixity
- , module GHC.Hs.Basic
)
where
import GHC.Prelude
import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) )
-import GHC.Hs.Basic () -- For instances only
------------------------
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -319,13 +319,6 @@ type instance XXHeader (GhcPass p) = DataConCantHappen
deriving instance Eq (Header (GhcPass p))
-instance NFData (CType (GhcPass p)) where
- rnf (CType ext mh fs) =
- rnf ext `seq` rnf mh `seq` rnf fs
-
-instance NFData (Header (GhcPass p)) where
- rnf (Header s h) =
- rnf s `seq` rnf h
instance NFData CCallStaticTargetUnit where
rnf = \case
@@ -388,14 +381,6 @@ instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
GhcTc -> x1 == x2
_ -> False
-instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where
- rnf = \case
- DynamicTarget NoExtField -> ()
- StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of
- GhcPs -> rnf x
- GhcRn -> rnf x
- GhcTc -> rnf x
-
instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where
put_ bh = \case
StaticTarget x a b -> do
=====================================
compiler/GHC/Types/InlinePragma.hs
=====================================
@@ -9,16 +9,8 @@
-}
{-# OPTIONS_GHC -Wno-orphans #-}
-{-
-Suppression of warnings are required for instances:
- - Binary Activation
- - Binary CompilerPhase
- - Binary InlinePragma
- - Binary InlineSaturation
- - Binary XActivation
- - Binary XInlinePragmaGhc
- - Outputable CompilerPhase
--}
+-- Required for TTG type-family definitions,
+-- There are no orphan type-class instances
module GHC.Types.InlinePragma
( -- * Inline Pragma Encoding
@@ -494,10 +486,6 @@ no harm.
always returns 'False' when its second argument is 'NeverActive'.
-}
-{- TODO: These orphan instance should be moved to the GHC.Utils.{Binary,Outputable}
-modules once TTG has progressed and the Language.Haskell.Syntax.Types module
-no longer depends on importing GHC.Hs.Doc.
--}
instance Binary XInlinePragmaGhc where
put_ bh (XInlinePragmaGhc s a) = do
put_ bh s
@@ -508,26 +496,6 @@ instance Binary XInlinePragmaGhc where
a <- get bh
return (XInlinePragmaGhc s a)
-instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where
- put_ bh (InlinePragma s a b c) = do
- put_ bh a
- put_ bh b
- put_ bh c
- case ghcPass @p of
- GhcPs -> put_ bh s
- GhcRn -> put_ bh s
- GhcTc -> put_ bh s
-
- get bh = do
- a <- get bh
- b <- get bh
- c <- get bh
- s <- case ghcPass @p of
- GhcPs -> get bh
- GhcRn -> get bh
- GhcTc -> get bh
- return (InlinePragma s a b c)
-
instance Binary InlineSaturation where
put_ bh AnySaturation = putByte bh 0
put_ bh (AppliedToAtLeast w) = putByte bh 1 *> put_ bh w
@@ -620,5 +588,24 @@ pprInline' emptyInline (InlinePragma
AnySaturation -> empty
AppliedToAtLeast ar -> parens (text "sat-args=" <> int ar)
+{- TODO: This orphan instance should be moved to GHC.Utils.Outputable once that
+module can import 'GhcPass' without causing an import cycle.
+@
+┌──────▶ GHC.Utils.Outputable
+│ │
+│ │ Needs to access GhcPass for instance:
+│ │ Outputable (InlinePragma (GhcPass p))
+│ ▼
+│ GHC.Hs.Extension.GhcPass
+│ │
+│ │ For GenLocated, SrcSpan, unLoc
+│ ▼
+│ GHC.Types.SrcLoc
+│ │
+│ │ for Outputable, SDoc,
+│ │ pprFastFilePath, ppr combinators
+└───────────────┘
+@
+-}
instance forall p. IsPass p => Outputable (InlinePragma (GhcPass p)) where
ppr = pprInline
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -68,7 +68,8 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
import GHC.Word ( Word64 )
import Data.Char ( chr, ord, isPrint )
-import Language.Haskell.Syntax.Module.Name
+import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )
+import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
{-
************************************************************************
@@ -419,6 +420,8 @@ instance Uniquable Word64 where
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
+instance Uniquable FieldLabelString where
+ getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs)
{-
************************************************************************
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -129,7 +129,6 @@ import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Hs.Specificity ()
import Language.Haskell.Syntax.Specificity
import Control.DeepSeq
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -1,5 +1,8 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DerivingVia #-}
@@ -119,8 +122,13 @@ import GHC.Prelude
import Language.Haskell.Syntax.Basic
import Language.Haskell.Syntax.Binds.InlinePragma
+import Language.Haskell.Syntax.Decls.Overlap
+import Language.Haskell.Syntax.Doc
+import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Module.Name (ModuleName(..))
import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
+import Language.Haskell.Syntax.Specificity
+import Language.Haskell.Syntax.Type (PromotionFlag(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.ShortText (ShortText)
@@ -164,7 +172,7 @@ import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
-import Data.Time
+import Data.Time hiding ( Nominal )
import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
@@ -1926,6 +1934,85 @@ instance Binary ModuleName where
put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs)
+instance Binary Specificity where
+ put_ bh SpecifiedSpec = putByte bh 0
+ put_ bh InferredSpec = putByte bh 1
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return SpecifiedSpec
+ _ -> return InferredSpec
+
+instance Binary ForAllTyFlag where
+ put_ bh Required = putByte bh 0
+ put_ bh Specified = putByte bh 1
+ put_ bh Inferred = putByte bh 2
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return Required
+ 1 -> return Specified
+ _ -> return Inferred
+
+instance Binary HsDocStringDecorator where
+ put_ bh x = case x of
+ HsDocStringNext -> putByte bh 0
+ HsDocStringPrevious -> putByte bh 1
+ HsDocStringNamed n -> putByte bh 2 >> put_ bh n
+ HsDocStringGroup n -> putByte bh 3 >> put_ bh n
+
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 0 -> pure HsDocStringNext
+ 1 -> pure HsDocStringPrevious
+ 2 -> HsDocStringNamed <$> get bh
+ 3 -> HsDocStringGroup <$> get bh
+ t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
+
+instance Binary HsDocStringChunk where
+ put_ bh (HsDocStringChunk bs) = put_ bh bs
+ get bh = HsDocStringChunk <$> get bh
+
+instance ( Binary (XInlinePragma p)
+ , Binary (Activation p)
+ , XXInlinePragma p ~ DataConCantHappen
+ ) => Binary (InlinePragma p) where
+ put_ bh (InlinePragma s a b c) = do
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh s
+
+ get bh = do
+ a <- get bh
+ b <- get bh
+ c <- get bh
+ s <- get bh
+ return (InlinePragma s a b c)
+
+instance ( Binary (XOverlapMode p)
+ , XXOverlapMode p ~ DataConCantHappen
+ ) => Binary (OverlapMode p) where
+ put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s
+ put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s
+ put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s
+ put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s
+ put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
+ put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> get bh >>= \s -> return $ NoOverlap s
+ 1 -> get bh >>= \s -> return $ Overlaps s
+ 2 -> get bh >>= \s -> return $ Incoherent s
+ 3 -> get bh >>= \s -> return $ Overlapping s
+ 4 -> get bh >>= \s -> return $ Overlappable s
+ _ -> get bh >>= \s -> return $ NonCanonical s
+
newtype BinLocated a = BinLocated { unBinLocated :: Located a }
instance Binary a => Binary (BinLocated a) where
@@ -2087,6 +2174,26 @@ instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool
b <- get bh
pure $ if b then Boxed else Unboxed
+instance Binary Fixity where
+ put_ bh (Fixity aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (Fixity aa ab)
+
+instance Binary FixityDirection where
+ put_ bh InfixL = putByte bh 0
+ put_ bh InfixR = putByte bh 1
+ put_ bh InfixN = putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return InfixL
+ 1 -> return InfixR
+ _ -> return InfixN
+
instance Binary ConInfoTable where
get bh = Binary.decode <$> get bh
@@ -2149,3 +2256,49 @@ instance Binary RuleMatchInfo where
h <- getByte bh
if h == 1 then pure ConLike
else pure FunLike
+
+instance Binary Role where
+ put_ bh Nominal = putByte bh 1
+ put_ bh Representational = putByte bh 2
+ put_ bh Phantom = putByte bh 3
+
+ get bh = do tag <- getByte bh
+ case tag of 1 -> return Nominal
+ 2 -> return Representational
+ 3 -> return Phantom
+ _ -> panic ("get Role " ++ show tag)
+
+instance Binary SrcStrictness where
+ put_ bh SrcLazy = putByte bh 0
+ put_ bh SrcStrict = putByte bh 1
+ put_ bh NoSrcStrict = putByte bh 2
+
+ get bh =
+ do h <- getByte bh
+ case h of
+ 0 -> return SrcLazy
+ 1 -> return SrcStrict
+ _ -> return NoSrcStrict
+
+instance Binary SrcUnpackedness where
+ put_ bh SrcNoUnpack = putByte bh 0
+ put_ bh SrcUnpack = putByte bh 1
+ put_ bh NoSrcUnpack = putByte bh 2
+
+ get bh =
+ do h <- getByte bh
+ case h of
+ 0 -> return SrcNoUnpack
+ 1 -> return SrcUnpack
+ _ -> return NoSrcUnpack
+
+instance Binary PromotionFlag where
+ put_ bh NotPromoted = putByte bh 0
+ put_ bh IsPromoted = putByte bh 1
+
+ get bh = do
+ n <- getByte bh
+ case n of
+ 0 -> return NotPromoted
+ 1 -> return IsPromoted
+ _ -> fail "Binary(IsPromoted): fail)"
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -115,12 +115,17 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName )
import Language.Haskell.Syntax.Basic
import Language.Haskell.Syntax.Binds.InlinePragma
import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) )
+import Language.Haskell.Syntax.Doc
+import Language.Haskell.Syntax.ImpExp ( NamespaceSpecifier(..) )
import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
+import Language.Haskell.Syntax.Specificity
import Language.Haskell.Syntax.Text
+import Language.Haskell.Syntax.Type ( PromotionFlag(..) )
import GHC.Prelude.Basic
import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS)
+import GHC.Utils.Encoding ( utf8DecodeByteString )
import GHC.Data.FastString
import qualified GHC.Utils.Ppr as Pretty
import qualified GHC.Utils.Ppr.Colour as Col
@@ -1108,6 +1113,28 @@ instance Outputable Extension where
instance Outputable ModuleName where
ppr = pprModuleName
+instance Outputable FieldLabelString where
+ ppr (FieldLabelString l) = ppr l
+
+instance Outputable ForAllTyFlag where
+ ppr Required = text "[req]"
+ ppr Specified = text "[spec]"
+ ppr Inferred = text "[infrd]"
+
+instance Outputable HsDocStringDecorator where
+ ppr HsDocStringNext = text "|"
+ ppr HsDocStringPrevious = text "^"
+ ppr (HsDocStringNamed n) = char '$' <> text n
+ ppr (HsDocStringGroup n) = text (replicate n '*')
+
+instance Outputable HsDocStringChunk where
+ ppr (HsDocStringChunk bs) = text (utf8DecodeByteString bs)
+
+-- | For compatibility with the existing @-ddump-parsed@ output, we only show
+-- the docstring.
+instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
+ ppr (WithHsDocIdentifiers s _ids) = ppr s
+
instance Outputable OsPath where
ppr p = text $ either show id (decodeUtf p)
@@ -2039,6 +2066,35 @@ instance Outputable TopLevelFlag where
ppr TopLevel = text "<TopLevel>"
ppr NotTopLevel = text "<NotTopLevel>"
+instance Outputable LexicalFixity where
+ ppr Prefix = text "Prefix"
+ ppr Infix = text "Infix"
+
+instance Outputable FixityDirection where
+ ppr InfixL = text "infixl"
+ ppr InfixR = text "infixr"
+ ppr InfixN = text "infix"
+
+instance Outputable Fixity where
+ ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
+
+instance Outputable SrcStrictness where
+ ppr SrcLazy = char '~'
+ ppr SrcStrict = char '!'
+ ppr NoSrcStrict = empty
+
+instance Outputable SrcUnpackedness where
+ ppr SrcUnpack = text "{-# UNPACK #-}"
+ ppr SrcNoUnpack = text "{-# NOUNPACK #-}"
+ ppr NoSrcUnpack = empty
+
+instance Outputable PromotionFlag where
+ ppr NotPromoted = text "NotPromoted"
+ ppr IsPromoted = text "IsPromoted"
+
+instance Outputable Role where
+ ppr = ftext . strFromRole
+
instance Outputable (OverlapMode p) where
ppr (NoOverlap _) = empty
ppr (Overlappable _) = text "[overlappable]"
@@ -2047,3 +2103,9 @@ instance Outputable (OverlapMode p) where
ppr (Incoherent _) = text "[incoherent]"
ppr (NonCanonical _) = text "[noncanonical]"
ppr (XOverlapMode _) = text "[user TTG extension]"
+
+instance Outputable (NamespaceSpecifier p) where
+ ppr NoNamespaceSpecifier{} = empty
+ ppr TypeNamespaceSpecifier{} = text "type"
+ ppr DataNamespaceSpecifier{} = text "data"
+ ppr (XNamespaceSpecifier _) = text "[user TTG extension]"
=====================================
compiler/Language/Haskell/Syntax/Basic.hs
=====================================
@@ -8,6 +8,7 @@ import Data.Data (Data)
import Data.Eq
import Data.Ord
import Data.Bool
+import Data.String (IsString(..))
import Prelude
{-
@@ -93,6 +94,20 @@ Field Labels
data Role = Nominal | Representational | Phantom
deriving (Eq, Ord, Data)
+instance NFData Role where
+ rnf Nominal = ()
+ rnf Representational = ()
+ rnf Phantom = ()
+
+-- These names are slurped into the parser code. Changing these strings
+-- will change the **surface syntax** that GHC accepts! If you want to
+-- change only the pretty-printing, do some replumbing. See
+-- mkRoleAnnotDecl in GHC.Parser.PostProcess
+strFromRole :: IsString s => Role -> s
+strFromRole Nominal = fromString "nominal"
+strFromRole Representational = fromString "representational"
+strFromRole Phantom = fromString "phantom"
+
{-
************************************************************************
* *
@@ -109,6 +124,11 @@ data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
| NoSrcStrict -- ^ no strictness annotation
deriving (Eq, Data)
+instance NFData SrcStrictness where
+ rnf SrcLazy = ()
+ rnf SrcStrict = ()
+ rnf NoSrcStrict = ()
+
-- | Source Unpackedness
--
-- What unpackedness the user requested
@@ -117,6 +137,11 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
| NoSrcUnpack -- ^ no unpack pragma
deriving (Eq, Data)
+instance NFData SrcUnpackedness where
+ rnf SrcNoUnpack = ()
+ rnf SrcUnpack = ()
+ rnf NoSrcUnpack = ()
+
{-
************************************************************************
* *
=====================================
compiler/Language/Haskell/Syntax/Decls/Foreign.hs
=====================================
@@ -74,7 +74,7 @@ import Control.DeepSeq
import Data.Data hiding (TyCon, Fixity, Infix)
import Data.Maybe
import Data.Eq
-import Prelude (Enum, Show)
+import Prelude (Enum, Show, seq)
{-
************************************************************************
@@ -211,6 +211,12 @@ data CCallTarget pass
| DynamicTarget (XDynamicTarget pass)
| XCCallTarget !(XXCCallTarget pass)
+instance (NFData (XStaticTarget pass), NFData (XDynamicTarget pass), NFData (XXCCallTarget pass))
+ => NFData (CCallTarget pass) where
+ rnf (StaticTarget x a b) = rnf x `seq` rnf a `seq` rnf b
+ rnf (DynamicTarget x) = rnf x
+ rnf (XCCallTarget x) = rnf x
+
data CExportSpec
-- | foreign export ccall foo :: ty
= CExportStatic
@@ -228,6 +234,11 @@ data CType pass
HText
| XCType !(XXCType pass)
+instance (NFData (XCType pass), NFData (Header pass), NFData (XXCType pass))
+ => NFData (CType pass) where
+ rnf (CType ext mh fs) = rnf ext `seq` rnf mh `seq` rnf fs
+ rnf (XCType x) = rnf x
+
-- | The filename for a C header file
data Header pass
= Header
@@ -235,6 +246,10 @@ data Header pass
HText
| XHeader !(XXHeader pass)
+instance (NFData (XHeader pass), NFData (XXHeader pass)) => NFData (Header pass) where
+ rnf (Header s h) = rnf s `seq` rnf h
+ rnf (XHeader x) = rnf x
+
data Safety
= PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or
-- switch threads, etc. So make sure things are
=====================================
compiler/Language/Haskell/Syntax/Doc.hs
=====================================
@@ -65,6 +65,18 @@ data HsDocString pass
| XHsDocString
!(XXHsDocString pass)
+instance
+ ( NFData (XMultiLineDocString pass)
+ , NFData (XNestedDocString pass)
+ , NFData (XGeneratedDocString pass)
+ , NFData (XXHsDocString pass)
+ , NFData (LHsDocStringChunk pass)
+ ) => NFData (HsDocString pass) where
+ rnf (MultiLineDocString x a b) = rnf x `seq` rnf a `seq` rnf b
+ rnf (NestedDocString x a b) = rnf x `seq` rnf a `seq` rnf b
+ rnf (GeneratedDocString x a) = rnf x `seq` rnf a
+ rnf (XHsDocString x) = rnf x
+
mkGeneratedHsDocString :: XGeneratedDocString p -> HsDocStringChunk -> HsDocString p
mkGeneratedHsDocString x = GeneratedDocString x
@@ -110,3 +122,6 @@ data WithHsDocIdentifiers a pass = WithHsDocIdentifiers
{ hsDocString :: !a
, hsDocIdentifiers :: ![LIdP pass]
}
+
+instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
+ rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i)
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -9,6 +9,7 @@ module Language.Haskell.Syntax.Extension where
-- This module captures the type families to precisely identify the extension
-- points for GHC.Hs syntax
+import Control.DeepSeq
import Data.Type.Equality (type (~))
import Data.Data hiding ( Fixity )
@@ -16,6 +17,7 @@ import Data.Kind (Type)
import Data.Eq
import Data.Ord
+import Text.Show
{-
Note [Trees That Grow]
@@ -62,6 +64,9 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension.
data NoExtField = NoExtField
deriving (Data,Eq,Ord)
+instance NFData NoExtField where
+ rnf NoExtField = ()
+
-- | Used when constructing a term with an unused extension point.
noExtField :: NoExtField
noExtField = NoExtField
@@ -95,7 +100,10 @@ can only do that if the extension field was strict (#18764).
See also [DataConCantHappen and strict fields].
-}
data DataConCantHappen
- deriving (Data,Eq,Ord)
+ deriving (Data,Eq,Ord,Show)
+
+instance NFData DataConCantHappen where
+ rnf = dataConCantHappen
-- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur].
dataConCantHappen :: DataConCantHappen -> a
=====================================
compiler/Language/Haskell/Syntax/ImpExp.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module Language.Haskell.Syntax.Extension
module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where
import Language.Haskell.Syntax.Doc (LHsDoc)
@@ -6,9 +8,9 @@ import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Module.Name
import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) )
-import Data.Eq (Eq)
+import Data.Eq (Eq(..))
import Data.Data (Data)
-import Data.Bool (Bool)
+import Data.Bool (Bool(..))
import Data.Maybe (Maybe)
import Data.String (String)
import Data.Int (Int)
=====================================
compiler/Language/Haskell/Syntax/Specificity.hs
=====================================
@@ -14,6 +14,7 @@ module Language.Haskell.Syntax.Specificity (
import Prelude
+import Control.DeepSeq (NFData(..))
import Data.Data
-- | ForAllTyFlag
@@ -27,6 +28,10 @@ data ForAllTyFlag = Invisible !Specificity
deriving (Eq, Ord, Data)
-- (<) on ForAllTyFlag means "is less visible than"
+instance NFData ForAllTyFlag where
+ rnf (Invisible spec) = rnf spec
+ rnf Required = ()
+
-- | Whether an 'Invisible' argument may appear in source Haskell.
data Specificity = InferredSpec
-- ^ the argument may not appear in source Haskell, it is
@@ -36,6 +41,10 @@ data Specificity = InferredSpec
-- required.
deriving (Eq, Ord, Data)
+instance NFData Specificity where
+ rnf SpecifiedSpec = ()
+ rnf InferredSpec = ()
+
pattern Inferred, Specified :: ForAllTyFlag
pattern Inferred = Invisible InferredSpec
pattern Specified = Invisible SpecifiedSpec
=====================================
compiler/ghc.cabal.in
=====================================
@@ -566,7 +566,6 @@ Library
GHC.Hs.Instances
GHC.Hs.Lit
GHC.Hs.Pat
- GHC.Hs.Specificity
GHC.Hs.Stats
GHC.HsToCore
GHC.HsToCore.Arrows
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -113,7 +113,6 @@ GHC.Hs.ImpExp
GHC.Hs.Instances
GHC.Hs.Lit
GHC.Hs.Pat
-GHC.Hs.Specificity
GHC.Hs.Type
GHC.Hs.Utils
GHC.HsToCore.Errors.Types
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bff295f20b167b3cd5a25a8999be8eb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bff295f20b167b3cd5a25a8999be8eb…
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] 21 commits: Coercion optimisation: avoid double-Sym for InstCo
by Marge Bot (＠marge-bot) 17 Jul '26
by Marge Bot (＠marge-bot) 17 Jul '26
17 Jul '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e7558997 by sheaf at 2026-07-17T14:04:16-04:00
Coercion optimisation: avoid double-Sym for InstCo
Ticket #27374 pointed out an issue with GHC.Core.Coercion.Opt.optCoercion's
handling of InstCo: it contravened (LC2) in Note [The LiftingContext in optCoercion]
because it applied the ambient 'sym' to a coercion that was then added
to the lifting context substitution.
Fixes #27374
Co-authored-by: Simon Jakobi <simon.jakobi(a)gmail.com>
- - - - -
ee8fe3fa by sheaf at 2026-07-17T14:04:16-04:00
Coercion optimisation: avoid exponential behaviour
The change to coercion optimisation of 'InstCo' in the previous commit
introduces exponential behaviour to the coercion optimiser. To avoid
this, this commit provides a way to push in 'Sym' of an already-optimised
coercion: GHC.Core.Coercion.Opt.mkDeepSymCo.
See Note [Pushing Sym without re-optimising] in GHC.Core.Coercion.Opt.
- - - - -
80441380 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Move THREADED_RTS-conditional struct members to end of Capability
Accessing members of the Capability struct from CMM code rely on
accessor macros. (The macros are generated by deriveConstants).
These macros have a single definition. This means that the offsets of
all struct members must *not* vary based on THREADED_RTS vs
!THREADED_RTS. This requires that any struct members that are
conditional on THREADED_RTS must occur after the unconditional struct
members. Hence we move all the ones that are conditional on
THREADED_RTS to the end.
Add a deriveConstants entry for the iomgr member of the Capability
struct, which was the motivation for this change.
Add warning messages to help our future selves. Debugging this took me
a couple hours in gdb!
- - - - -
e6644010 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Make the IOManager API use CapIOManager rather than Capability
This makes the API somewhat more self-contained and more consistent.
Now the IOManager API and each of the backends takes just the I/O
manager structure. Previously we had a bit of a mixture, depending on
whether the function needed access to the Capability or just the
CapIOManager.
We still need access to the cap, so we introduce a back reference to
reach the capability, via iomgr->cap.
Convert all uses in select and poll backends, but not win32 ones.
Convert callers in the scheduler and elsewhere.
Also convert the three CMM primops that call IOManager APIs. They just
need to use Capability_iomgr(MyCapability()).
- - - - -
3d395b47 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Split posix/MIO.c out of posix/Signals.c
The MIO I/O manager was secretly living inside the Signals file.
Now it gets its own file, like any other self-respecting I/O manager.
- - - - -
66a8875a by Duncan Coutts at 2026-07-17T14:04:17-04:00
Rationalise some scheduler run queue utilities
Move them all to the same place in the file.
Make some static that were used only internally.
Also remove a redundant assignment after calling truncateRunQueue that
is already done within truncateRunQueue.
- - - - -
b7423102 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Rename initIOManager{AfterFork} to {re}startIOManager
These are more accurate names, since these actions happen after
initialisation and are really about starting (or restarting) background
threads.
- - - - -
f974e226 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Free per-cap I/O managers during shutdown and forkProcess
Historically this was not strictly necessary. The select and win32
legacy I/O managers did not maintain any dynamically allocated
resources. The new poll one does (an auxillary table), and so this
should be freed.
After forkProcess, all threads get deleted. This includes threads
waiting on I/O or timers. So as of this patch, resetting the I/O
manager is just about tidying things up. For example, for the poll
I/O manager this will reset the size of the AIOP table (which
otherwise grows but never shrinks).
In future however the re-initialising will become neeecessary for
functionality, since some I/O managers will need to re-initialise
wakeup fds that are set CLOEXEC.
- - - - -
e9fd77f5 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add a TODO to the MIO I/O manager
The direction of travel is to make I/O managers per-capability and have
all their state live in the struct CapIOManager. The MIO I/O manager
however still has a number of global variables.
It's not obvious how handle these globals however.
- - - - -
a7f1fbc4 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add a FIXME note in the Poll I/O manager
- - - - -
300bacc5 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add missing updateRemembSetPushClosure in poll I/O manager
For the non-moving GC.
- - - - -
2f2401d7 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Minor doc improvement to struct StgAsyncIOOp member outcome
Mention the enumeration names, as well as their numeric values. The rest
of the code uses the enum names.
- - - - -
687770ac by Duncan Coutts at 2026-07-17T14:04:17-04:00
Minor doc improvements for StgTSOBlockInfo
Clarify that certain union members are used only by certain legacy
I/O managers. Hopefully we will be able to remove these at some point.
- - - - -
cbeb23e0 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Avoid exporting various win32-specific rts symbols
The BeginPrivate.h / EndPrivate.h scheme works perfectly well on
Windows, but all of the rts/win32/*.h files were not using it.
- - - - -
034fbebe by Duncan Coutts at 2026-07-17T14:04:17-04:00
Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
We no longer need wakeupIOManager for the threaded RTS case, so we can
remove it and the bits only needed to support it. This includes the
pipe/eventfd fd shared between the RTS and the in-library I/O manager
used for waking up the I/O manager thread. The pipe/eventfd still
exists, but it no longer has to be communicated to the RTS, since the
RTS no longer needs to use it.
So we remove the RTS API export setIOManagerWakeupFd, and remove uses of
it within the I/O managers in ghc-internal.
- - - - -
73327f80 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add a new interruptIOManager API for the I/O managers
It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the
return type and docs for awaitCompletedTimeoutsOrIO to have it return
false when it gets interrupted, and have no useful post condition in
that case.
- - - - -
70a84cf2 by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add interruptIOManager support for select I/O manager
Uses the FdWakup mechanism.
- - - - -
5525e28a by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add interruptIOManager support for poll I/O manager
Uses the FdWakup mechanism.
A quirk we have to cope with is that we now need to poll one more fd --
the wakeup_fd_r -- but this fd has no corresponding entry in the
aiop_table. This is awkward since we have set up our aiop_poll_table to
be an auxilliary table with matching indicies.
The solution this patch uses (and described in the comments) is to have
two tables: struct pollfd *aiop_poll_table, *full_poll_table;
and to have the aiop_poll_table alias the tail of the full_poll_table.
The head entry in the full_poll_table is the extra fd. So we poll the
full_poll_table, while the aiop_poll_table still has matching indicies
with the aiop_table.
Hurrah for C aliasing rules.
- - - - -
8aff74fa by Duncan Coutts at 2026-07-17T14:04:17-04:00
Add interruptIOManager support for win32 legacy I/O manager
And remove unused related helper resetAbandonRequestWait. It is not
called because the event is created in auto-reset mode, so never needs
to be reset manually.
- - - - -
1f39e4c3 by Duncan Coutts at 2026-07-17T14:04:18-04:00
Note lack of interruptIOManager support for WinIO I/O manager
Though there's a plausible design, we can't sanely test it at the moment
due to related WinIO bugs. Filed as issue #27403.
- - - - -
be3c7b6b by Duncan Coutts at 2026-07-17T14:04:18-04:00
Be more explicit about enum IOReadOrWrite values, and type within cmm
Belt and braces.
- - - - -
44 changed files:
- + changelog.d/T27374
- compiler/GHC/Core/Coercion/Opt.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/Capability.c
- rts/Capability.h
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/Schedule.h
- rts/include/rts/IOInterface.h
- rts/include/rts/storage/Closures.h
- rts/include/rts/storage/TSO.h
- rts/posix/FdWakeup.h
- + rts/posix/MIO.c
- + rts/posix/MIO.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Select.h
- rts/posix/Signals.c
- rts/posix/Signals.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/rts.cabal
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- rts/win32/AsyncWinIO.h
- rts/win32/AwaitEvent.c
- rts/win32/AwaitEvent.h
- rts/win32/ConsoleHandler.h
- rts/win32/MIOManager.h
- rts/win32/ThrIOManager.h
- rts/win32/WorkQueue.h
- rts/win32/veh_excn.h
- + testsuite/tests/corelint/T27374.hs
- testsuite/tests/corelint/all.T
- utils/deriveConstants/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b45647cc13fa30ac735294fd3ec1b3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b45647cc13fa30ac735294fd3ec1b3…
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] 5 commits: Remove the now unneeded enabling of scoped type variables
by Wolfgang Jeltsch (＠jeltsch) 17 Jul '26
by Wolfgang Jeltsch (＠jeltsch) 17 Jul '26
17 Jul '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC
Commits:
36332be8 by Wolfgang Jeltsch at 2026-07-17T17:21:16+03:00
Remove the now unneeded enabling of scoped type variables
- - - - -
54b4b8a1 by Wolfgang Jeltsch at 2026-07-17T18:14:49+03:00
Fix a documentation linking error
- - - - -
8a39d728 by Wolfgang Jeltsch at 2026-07-17T18:42:06+03:00
Assert that `pprFixedSizeNatural` takes a natural number
- - - - -
7db7343b by Wolfgang Jeltsch at 2026-07-17T20:27:36+03:00
Fix Markup in a comment
- - - - -
2f58c3a2 by Wolfgang Jeltsch at 2026-07-17T20:37:20+03:00
Add Haddock documentation
- - - - -
1 changed file:
- compiler/GHC/ByteCode/Show.hs
Changes:
=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -1,8 +1,8 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
--- | […]
+-- | This module implements the output of textual information about the contents
+-- of bytecode files. It is the backbone of the @--show-byte-code@ option.
module GHC.ByteCode.Show (showByteCode) where
import Prelude ((+), (-), Integral, div)
@@ -79,7 +79,7 @@ import GHC.Driver.Env.Types (HscEnv)
import GHCi.FFI (FFIType)
import GHCi.Message (ConInfoTable (..))
--- | […]
+-- | Outputs textual information about the contents of a bytecode file.
showByteCode :: Logger -> HscEnv -> FilePath -> IO ()
showByteCode logger env path = do
byteCode <- readOnDiskModuleByteCode env path
@@ -88,7 +88,7 @@ showByteCode logger env path = do
noSrcSpan
(withPprStyle defaultDumpStyle $ pprOnDiskModuleByteCode byteCode)
--- | […]
+-- | Constructs textual information about the contents of a bytecode file.
pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc
pprOnDiskModuleByteCode OnDiskModuleByteCode {..}
= vcat [
@@ -97,15 +97,15 @@ pprOnDiskModuleByteCode OnDiskModuleByteCode {..}
pprCompiledByteCode odgbc_module $ odgbc_compiled_byte_code
]
--- | […]
+-- | Constructs textual information about the name of a module.
pprModuleIdent :: Module -> SDoc
pprModuleIdent = entry (text "name") . ppr
--- | […]
+-- | Constructs textual information about the hash of a module.
pprOnDiskModuleByteCodeHash :: Fingerprint -> SDoc
pprOnDiskModuleByteCodeHash = entry (text "hash") . ppr
--- | […]
+-- | Constructs textual information about bytecode.
pprCompiledByteCode :: Module -> CompiledByteCode -> SDoc
pprCompiledByteCode currentModule CompiledByteCode {..}
= vcat [
@@ -117,14 +117,14 @@ pprCompiledByteCode currentModule CompiledByteCode {..}
pprHPCInfo $ bc_hpc_info
]
--- | […]
+-- | Constructs textual information about bytecode objects.
pprByteCodeObjects :: Module -> FlatBag UnlinkedBCO -> SDoc
pprByteCodeObjects currentModule = entry (text "objects") .
vcatOrNone .
map (pprByteCodeObject currentModule) .
elemsFlatBag
--- | […]
+-- | Constructs textual information about a single bytecode object.
pprByteCodeObject :: Module -> UnlinkedBCO -> SDoc
pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of
UnlinkedBCO {..}
@@ -147,26 +147,29 @@ pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of
pprPointers currentModule $ unlinkedStaticConPtrs
]
--- | […]
+-- | Constructs textual information about the arity of an ordinary bytecode
+-- object.
pprArity :: Int -> SDoc
pprArity = entry (text "arity") . ppr
--- | […]
+-- | Constructs textual information about the data constructor name of a
+-- static-construction bytecode object.
pprDataConstructorName :: Name -> SDoc
pprDataConstructorName = entry (text "data constructor name") . ppr
--- | […]
+-- | Constructs textual information about the liftedness of a
+-- static-construction bytecode object.
pprLiftedness :: Bool -> SDoc
pprLiftedness = entry (text "lifted") . noOrYes
--- | […]
+-- | Constructs textual information about literals.
pprLiterals :: Module -> FlatBag BCONPtr -> SDoc
pprLiterals currentModule = entry (text "literals") .
vcatOrNone .
map (pprLiteral currentModule) .
elemsFlatBag
--- | […]
+-- | Constructs textual information about a single literal.
pprLiteral :: Module -> BCONPtr -> SDoc
pprLiteral currentModule literal = case literal of
BCONPtrWord word
@@ -194,20 +197,20 @@ pprLiteral currentModule literal = case literal of
-> text "cost center of breakpoint" <+>
pprInternalBreakpointID currentModule breakpointID
--- | […]
+-- | Constructs textual information about some FFI info.
pprFFIInfo :: FFIInfo -> SDoc
pprFFIInfo FFIInfo {..}
= hsep (map (pprFFIType >>> (<+> text "->")) ffiInfoArgs) <+>
pprFFIType ffiInfoRet
--- | […]
+-- | Constructs textual information about an FFI type.
pprFFIType :: FFIType -> SDoc
pprFFIType ffiType = assert (take 3 ident == "FFI") $ text (drop 3 ident) where
ident :: String
ident = show ffiType
--- | […]
+-- | Constructs textual information about the ID of a bytecode breakpoint.
pprInternalBreakpointID :: Module -> InternalBreakpointId -> SDoc
pprInternalBreakpointID currentModule InternalBreakpointId {..}
| ibi_info_mod == currentModule = indexDoc
@@ -219,14 +222,14 @@ pprInternalBreakpointID currentModule InternalBreakpointId {..}
indexDoc :: SDoc
indexDoc = ppr ibi_info_index
--- | […]
+-- | Constructs textual information about pointers.
pprPointers :: Module -> FlatBag BCOPtr -> SDoc
pprPointers currentModule = entry (text "utilized items") .
vcatOrNone .
map (pprPointer currentModule) .
elemsFlatBag
--- | […]
+-- | Constructs textual information about a single pointer.
pprPointer :: Module -> BCOPtr -> SDoc
pprPointer currentModule pointer = case pointer of
BCOPtrName name
@@ -238,13 +241,13 @@ pprPointer currentModule pointer = case pointer of
BCOPtrBreakArray breakArrayModule
-> text "break array of module" <+> quotes (ppr breakArrayModule)
--- | […]
+-- | Constructs textual information about data constructor info tables.
pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc
pprDataConstructorInfoTables = entry (text "data constructor info tables") .
vcatOrNone .
map (uncurry pprDataConstructorInfoTable)
--- | […]
+-- | Constructs textual information about a single data constructor info table.
pprDataConstructorInfoTable :: Name -> ConInfoTable -> SDoc
pprDataConstructorInfoTable dataConstrName ConInfoTable {..}
= entry (text "info table of" <+> quotes (ppr dataConstrName)) $
@@ -253,21 +256,21 @@ pprDataConstructorInfoTable dataConstrName ConInfoTable {..}
pprNonPointerWordCount $ conItblNPtrs
]
--- | […]
+-- | Constructs textual information about a number of pointer words.
pprPointerWordCount :: Int -> SDoc
pprPointerWordCount = entry (text "number of words for pointers") . ppr
--- | […]
+-- | Constructs textual information about a number of non-pointer words.
pprNonPointerWordCount :: Int -> SDoc
pprNonPointerWordCount = entry (text "number of words for non-pointers") . ppr
--- | […]
+-- | Constructs textual information about top-level strings.
pprTopLevelStrings :: [(Name, ByteString)] -> SDoc
pprTopLevelStrings = entry (text "top-level strings") .
vcatOrNone .
map (uncurry pprTopLevelString)
--- | […]
+-- | Constructs textual information about a single top-level string.
pprTopLevelString :: Name -> ByteString -> SDoc
pprTopLevelString stringName encodedString = entry (ppr stringName) $
text $
@@ -275,13 +278,13 @@ pprTopLevelString stringName encodedString = entry (ppr stringName) $
utf8DecodeByteString $
encodedString
--- | […]
+-- | Constructs textual information about breakpoints.
pprBreakpoints :: Module -> Maybe InternalModBreaks -> SDoc
pprBreakpoints currentModule
= entry (text "breakpoints") .
maybe (text "<none>") (pprBreakpointsData currentModule)
--- | […]
+-- | Constructs textual information about a single breakpoint.
pprBreakpointsData :: Module -> InternalModBreaks -> SDoc
pprBreakpointsData currentModule InternalModBreaks {..}
= vcat [
@@ -289,7 +292,7 @@ pprBreakpointsData currentModule InternalModBreaks {..}
pprByteCodeBreakpoints currentModule $ imodBreaks_breakInfo
]
--- | […]
+-- | Constructs textual information about source breakpoints.
pprSourceBreakpoints :: Module -> ModBreaks -> SDoc
pprSourceBreakpoints currentModule ModBreaks {..}
= entry (text "source breakpoints") $
@@ -301,12 +304,12 @@ pprSourceBreakpoints currentModule ModBreaks {..}
(elems modBreaks_locs_)
(elems modBreaks_decls)
(elems modBreaks_vars)
- -- The cost center infos in `modBreaks_ccs`, when present, just contain
- -- textual representations of the declaration paths in `modBreaks_decls`
- -- and the source spans in `modBreaks_locs_` and are therefore never
+ -- The cost center infos in 'modBreaks_ccs', when present, just contain
+ -- textual representations of the declaration paths in 'modBreaks_decls'
+ -- and the source spans in 'modBreaks_locs_' and are therefore never
-- shown.
--- | […]
+-- | Constructs textual information about a single source breakpoint.
pprSourceBreakpoint :: BreakTickIndex
-> BinSrcSpan
-> [String]
@@ -320,19 +323,19 @@ pprSourceBreakpoint ix srcSpan declarationPath freeVars
pprFreeVariables $ freeVars
]
--- | […]
+-- | Constructs textual information about a source span.
pprSrcSpan :: BinSrcSpan -> SDoc
pprSrcSpan = entry (text "source span") . ppr . unBinSrcSpan
--- | […]
+-- | Constructs textual information about a declaration path.
pprDeclarationPath :: [String] -> SDoc
pprDeclarationPath = entry (text "declaration path") . vcatOrEmpty . map text
--- | […]
+-- | Constructs textual information about free variables.
pprFreeVariables :: [OccName] -> SDoc
pprFreeVariables = entry (text "free variables") . vcatOrNone . map ppr
--- | […]
+-- | Constructs textual information about bytecode breakpoints.
pprByteCodeBreakpoints :: Module -> IntMap CgBreakInfo -> SDoc
pprByteCodeBreakpoints currentModule
= entry (text "bytecode breakpoints") .
@@ -340,7 +343,7 @@ pprByteCodeBreakpoints currentModule
map (uncurry (pprByteCodeBreakpoint currentModule)) .
IntMap.toList
--- | […]
+-- | Constructs textual information about a single bytecode breakpoint.
pprByteCodeBreakpoint :: Module -> Int -> CgBreakInfo -> SDoc
pprByteCodeBreakpoint currentModule ix CgBreakInfo {..}
= entry (text "bytecode breakpoint" <+> ppr ix) $
@@ -353,38 +356,41 @@ pprByteCodeBreakpoint currentModule ix CgBreakInfo {..}
-- That the 'cgb_resty' field holds the type of the breakpoint is apparent
-- from the fact that this field is set by
-- 'GHC.StgToByteCode.dehydrateCgBreakInfo' using one of its arguments and
- -- 'dehydrateCgBreakInfo' is always invoked with this argument set to the
- -- extension field of 'Breakpoint', which in turn holds the type of the
- -- breakpoint according to Note [Tickish passes] and the comment on the
- -- instance declaration of @XBreakpoint 'TickishPassStg@.
+ -- 'GHC.StgToByteCode.dehydrateCgBreakInfo' is always invoked with this
+ -- argument set to the extension field of 'Breakpoint', which in turn holds
+ -- the type of the breakpoint according to Note [Tickish passes] and the
+ -- comment on the instance declaration of @XBreakpoint 'TickishPassStg@.
+-- | Constructs textual information about a type.
pprType :: IfaceType -> SDoc
pprType = entry (text "type") . ppr
--- | […]
+-- | Constructs textual information about type variables.
pprTypeVariables :: [IfaceTvBndr] -> SDoc
pprTypeVariables = entry (text "type variables") .
vcatOrNone .
map pprTypeVariableBinder
--- | […]
+-- | Constructs textual information about a type variable binder.
pprTypeVariableBinder :: IfaceTvBndr -> SDoc
pprTypeVariableBinder (name, kind) = ppr name <+> text "::" <+> ppr kind
--- | […]
+-- | Constructs textual information about variables.
pprVariables :: [Maybe (IfaceIdBndr, Word)] -> SDoc
pprVariables = entry (text "variables") . vcatOrNone . map pprVariable
--- | […]
+-- | Constructs textual information about a single variable.
pprVariable :: Maybe (IfaceIdBndr, Word) -> SDoc
pprVariable = maybe (text "<unknown>") (pprVariableBinder . fst)
--- | […]
+-- | Constructs textual information about a variable binder.
pprVariableBinder :: IfaceIdBndr -> SDoc
pprVariableBinder (multiplicity, name, type_)
= text "%" <> ppr multiplicity <+>
ppr name <+> text "::" <+> ppr type_
+-- | Constructs textual information about a source breakpoint corresponding to a
+-- bytecode breakpoint.
pprCorrespondingSourceBreakpoint :: Module
-> Either InternalBreakLoc BreakpointId
-> SDoc
@@ -393,7 +399,7 @@ pprCorrespondingSourceBreakpoint currentModule
pprBreakpointID currentModule .
either internalBreakLoc id
--- | […] [analogous to 'pprInternalBreakpointID' but the meaning of the index is different]
+-- | Constructs textual information about the ID of a source breakpoint.
pprBreakpointID :: Module -> BreakpointId -> SDoc
pprBreakpointID currentModule BreakpointId {..}
| bi_tick_mod == currentModule = indexDoc
@@ -405,23 +411,23 @@ pprBreakpointID currentModule BreakpointId {..}
indexDoc :: SDoc
indexDoc = ppr bi_tick_index
--- | […]
+-- | Constructs textual information about static-pointer table entries.
pprStaticPointerTableEntries :: [SptEntry] -> SDoc
pprStaticPointerTableEntries = entry (text "static-pointer table entries") .
vcatOrNone .
map pprStaticPointerTableEntry
--- | […]
+-- | Constructs textual information about a single static-pointer table entry.
pprStaticPointerTableEntry :: SptEntry -> SDoc
pprStaticPointerTableEntry (SptEntry name fingerprint)
= ppr fingerprint <> text ":" <+> ppr name
--- | […]
+-- | Constructs textual information about some HPC info.
pprHPCInfo :: Strict.Maybe ByteCodeHpcInfo -> SDoc
pprHPCInfo = entry (text "HPC information") .
Strict.maybe (text "<none>") pprHPCInfoData
--- | […]
+-- | Constructs textual information about data that makes up some HPC info.
pprHPCInfoData :: ByteCodeHpcInfo -> SDoc
pprHPCInfoData ByteCodeHpcInfo {..}
= vcat [
@@ -432,30 +438,33 @@ pprHPCInfoData ByteCodeHpcInfo {..}
]
where
--- | […]
+-- | Constructs textual information about the hash of some HPC info.
pprHPCInfoHash :: Int -> SDoc
pprHPCInfoHash = entry (text "hash") . pprFixedSizeNatural
--- | […]
+-- | Constructs textual information about a module name.
pprModuleName :: ShortByteString -> SDoc
pprModuleName = entry (text "module name") .
text .
utf8DecodeShortByteString
--- | […]
+-- | Constructs textual information about a tick box name.
pprTickBoxName :: ShortByteString -> SDoc
pprTickBoxName = entry (text "tick box name") .
text .
utf8DecodeShortByteString
--- | […]
+-- | Constructs textual information about a number of tick counts.
pprTickCount :: Int -> SDoc
pprTickCount = entry (text "number of ticks") . ppr
--- | […]
+-- | Constructs a hexadecimal representation of a natural number such that the
+-- number of hexadecimal digits fits the number of bits used to represent the
+-- natural number.
pprFixedSizeNatural :: (Integral a, FiniteBits a) => a -> SDoc
pprFixedSizeNatural num
- = text $ replicate (digitCount - length unpadded) '0' ++ unpadded
+ = assert (num >= 0) $
+ text $ replicate (digitCount - length unpadded) '0' ++ unpadded
where
digitCount :: Int
@@ -464,20 +473,25 @@ pprFixedSizeNatural num
unpadded :: String
unpadded = showHex num ""
--- | […]
+-- | Constructs a textual representation of a boolean, interpreting 'True' and
+-- 'False' as “yes” and “no”, respectively.
noOrYes :: Bool -> SDoc
noOrYes bool = text (if bool then "yes" else "no")
--- | […]
-entry :: SDoc -> SDoc -> SDoc
+-- | Constructs an entry in a list of textual data representations.
+entry :: SDoc -- ^ The title of the entry
+ -> SDoc -- ^ The contents of the entry
+ -> SDoc -- ^ The entry
entry title content = hang (title <> text ":") 2 content
--- | […]
+-- | Composes documents vertically in general, but presents an empty document
+-- list as `<none`>.
vcatOrNone :: [SDoc] -> SDoc
vcatOrNone [] = text "<none>"
vcatOrNone docs = vcat docs
--- | […]
+-- | Composes documents vertically in general, but presents an empty document
+-- list as `<empty`>.
vcatOrEmpty :: [SDoc] -> SDoc
vcatOrEmpty [] = text "<empty>"
vcatOrEmpty docs = vcat docs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aeddc354c6672f1d89903200aac793…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aeddc354c6672f1d89903200aac793…
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/T27448] 28 commits: Fix a profiling race condition resulting in segfaults.
by Simon Jakobi (＠sjakobi2) 17 Jul '26
by Simon Jakobi (＠sjakobi2) 17 Jul '26
17 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC
Commits:
ed09895d by Andreas Klebinger at 2026-07-08T16:53:27-04:00
Fix a profiling race condition resulting in segfaults.
StgToCmm: Don't assume tagged FUN closures in closureCodeBody.
When entering a closure the self/node pointer might not be tagged in
some situations when a thunk is evaluated by multiple threads.
So we most AND away the tag bits rather than subtracting an expected tag.
Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC.
In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens
another thread or the GC itself might mutate the closure making entering it no longer
valid. We now check for this.
Add test and changelog for #27123 fixes.
- - - - -
67c03eb2 by Cheng Shao at 2026-07-08T16:54:09-04:00
ghc-heap: fix invalid srtlen returned by peekItbl when no-TNTC
This patch fixes the no-TNTC code path of `peekItbl` so that it looks
at the right memory address when reading the `srt` field from the
`StgInfoTable_` struct. Also adds a `T27465` regression test that
reproduces the bug on no-TNTC builds before the fix. Fixes #27465.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
2ecabb4f by Zubin Duggal at 2026-07-09T09:23:25-04:00
hadrian: binary-dist-dir should not be the default target
Revert behaviour to pre 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
In 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2, we applied the following behaviour change:
```
hadrian: Build stage 2 cross compilers
...
* hadrian: Make binary-dist-dir the default build target. This allows us
to have the logic in one place about which libraries/stages to build
with cross compilers. Fixes #24192
```
This is a major regression to development experience, a plain hadrian/build
--freeze1 now takes ages because we rebuild all docs (which need to go in the
binary dist dir).
`binary-dist-dir` is the wrong default target for regular GHC development work
Fixes #27445
- - - - -
e16388e3 by Zubin Duggal at 2026-07-09T09:23:25-04:00
.gitignore: Add the hadrian system.config introduced by commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
Since
commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
Author: Matthew Pickering <matthewtpickering(a)gmail.com>
Date: Thu Dec 21 16:17:41 2023 +0000
hadrian: Build stage 2 cross compilers
./configure produces /hadrian/cfg/system.config.{host,target}
Add these to .gitignore
- - - - -
7e8abf41 by Alan Zimmerman at 2026-07-09T09:24:12-04:00
EPA: Replace AnnListItem with simply [TrailingAnn]
Remove the unnecessary wrapper around a single field.
- - - - -
29032f17 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Keep real reason for fragile test failures
- - - - -
c34e03a7 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Fall back to the failure reason for empty JUnit bodies
- - - - -
409d40f0 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Show output diffs in JUnit output
Also refactor compare_outputs to return essentially a `Maybe Diff`
(`CompareOutput`) instead of a bool, but more pythonic. This
allows us to pass the diff through nice.
- - - - -
06fee1ab by Zubin Duggal at 2026-07-09T09:24:58-04:00
perf notes: include stat deviation and acceptance window in notes so they show up in gitlab
- - - - -
57c0f32c by mangoiv at 2026-07-10T11:08:38-04:00
driver: enable -finter-module-far-jumps by default
this fixes a compatibility bug with certain binutils/gcc versions where
we were seeing jump offset overflow errors.
This commit can probably reverted if we stop supporting the problematic
binutils/gcc verions (2.44 and 14.2, respectively)
Reolves #26994
- - - - -
4396a6f2 by Andrea Vezzosi at 2026-07-10T11:09:25-04:00
[Fix #27287] preserve ModBreaks in ModIface
- - - - -
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`.
- - - - -
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>
- - - - -
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
- - - - -
6bd1ad2a by Andreas Klebinger at 2026-07-14T18:01:49-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.
- - - - -
7eb0f1c9 by Cheng Shao at 2026-07-14T18:02:31-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>
- - - - -
ef038aae by cydparser at 2026-07-15T04:35:41-04:00
Reduce bytes allocated for `capabilities` in RTS (fixes #27487)
In rts/Capability.c, `capabilities` is an array of pointers, but it was allocated as if it were an
array of Capability's.
- - - - -
d377e83e by Cheng Shao at 2026-07-15T04:36:27-04:00
rts: fix missing UNTAG in stg_readTVarIOzh
This patch fixes missing UNTAG on the current value closure read from
StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word
aligned; it may be a tagged closure, and reading info table from the
tagged address is an unaligned load which may cause issues on
platforms with strict alignment requirements.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
8ed03842 by Cheng Shao at 2026-07-15T04:36:27-04:00
rts: fix missing UNTAG in stg_control0zh_ll
This patch fixes missing UNTAG on the cont closure returned by
captureContinuationAndAbort. In case it's not NULL,
captureContinuationAndAbort returns a tagged StgContinuation closure,
in which case it must be untagged before accessing the
apply_mask_frame field.
In the past it worked out of luck: when apply_mask_frame was NULL then
mask_frame_offset is also 0 so the control flow didn't diverge to a
wrong path. Still, this is horribly wrong and will crash once
StgContinuation struct is refactored and fields are shuffled around.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
5aa7000a by Cheng Shao at 2026-07-15T04:37:08-04:00
compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk
This patch fixes a double negation confusion in !7525 that results in
some redundant AP thunk code generation when not using
-ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate
whether precomputed AP thunks in the RTS should be used, which
defaults to `True`, unless `-ticky-ap-thunk` is passed.
`-finfo-table-map` now also implies `-ticky-ap-thunk`, since when
doing IPE profiling we want the generated AP thunks to be unique.
Fixes #27502.
-------------------------
Metric Decrease:
T3064
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
d43a7b7a by Brian McKenna at 2026-07-15T20:10:04+02:00
Strip ticks when desugaring bool guards
The special `considerAccessible` pattern was broken when compiling
with debug info. Compiling with debug info wraps expressions with
`SourceNote` ticks, which broke the internals of the
`desugarBoolGuard` function. Ticks are now ignored within this
function.
Fixes #27360
- - - - -
ede4b17b by Ben Gamari at 2026-07-15T22:59:53-04:00
base: Display ExceptionContext in WhileHandling's textual description
As originally-implemented the implementation for
`WhileHandling(displayExceptionAnnotation)` would display the
`ExceptionContext` of the exception which it carries (as this was the
behavior of `displayException`, in terms of which
`displayExceptionAnnotation` was implemented).
However, in 284ffab3 the definition of `SomeException(displayException)`
was changed to exclude the `ExceptionContext`. This means that
`WhileHandling(displayExceptionAnnotation)` fails to describe the
provenance of the exception which it captures, greatly limiting its
utility.
Return the implementation to its originally-specified behavior by
implementing `WhileHandling(displayExceptionAnnotation)` in terms of
`displayExceptionWithInfo`.
Fixes #27456.
- - - - -
0f64f348 by Cheng Shao at 2026-07-16T15:41:08+00:00
ci: add missing docker permission workaround in abi-test job
- - - - -
660cb239 by Cheng Shao at 2026-07-16T19:37:48+00:00
bindist: Fix make install -j race condition on macos/freebsd
This patch fixes make install -j race condition on macos/freebsd. BSD
install fails with EEXIST when multiple install processes concurrently
create the same prefix directory. So we add an `install_dirs`
prerequisite job that sequentially creates the directories for
subsequent jobs to work with. Fixes #27499.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
08130257 by Cheng Shao at 2026-07-16T19:37:48+00:00
ci: run bindist make install with -j
This patch makes the ci scripts run `make install` with `-j` to reduce
wall clock time when installing the bindist, see related issue for
benchmark numbers. This only affects ghc ci logic, the user-facing
default is up to distributors and is still `-j1`. Closes #27029.
- - - - -
d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00
Mark various language extension flags as deprecated (see #27329)
The following language extensions are now deprecated:
- AlternativeLayoutRule
- AlternativeLayoutRuleTransitional
- ParallelArrays
- PolymorphicComponents
- Rank2Types
In addition, the warning `-Walternative-layout-rule-transitional`
has been marked as deprecated, as it is emitted only under the
deprecated extension `XAlternativeLayoutRuleTransitional`.
- - - - -
fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00
base: re-export GHC.Environment.getFullArgs from System.Environment
CLC proposal https://github.com/haskell/core-libraries-committee/issues/431
- - - - -
14d85b50 by Simon Jakobi at 2026-07-17T18:09:50+02:00
NCG: optimize loopInfo.mkDomMap
Previously, mkDomMap built an intermediate association list with (++)
and a recursive concatMap before handing it to mapFromList. The
concatMap re-copied each node's list once per ancestor, so the work was
O(n^2) in the depth of the dominator tree.
The new code builds the LabelMap directly, with one mapInsert per
dominator-tree node, so each node is handled once.
This reduces allocation when compiling the new ManyBasicBlocks test by
~27% at -O1 and -O2. (At -O0, static control-flow prediction is
disabled.)
This also fixes a small inconsistency: previously a leaf of the
dominator tree included itself in its dominator set, while interior
nodes did not. The map is consumed only by isBackEdge, so the only
observable effect was that a self-loop edge was treated as a back edge
iff its block was a dominator-tree leaf. domMap now holds each block's
strict dominators, excluding the entry.
Closes #27448
Assisted-by: Claude Opus 4.8
- - - - -
183 changed files:
- .gitignore
- .gitlab-ci.yml
- .gitlab/ci.sh
- + changelog.d/T27123.md
- + changelog.d/T27329
- + changelog.d/T27360
- + changelog.d/T27456
- + changelog.d/fix-cmm-atomic-load-store
- + changelog.d/fix-make-install-j
- + changelog.d/fix-peekitbl-no-tntc
- + changelog.d/fix-use-std-ap-thunk
- + changelog.d/inter-module-far-jumps-aarch64-default
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- + compiler/GHC/HsToCore/Breakpoints/Types.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Platform/Ways.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/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/Rank.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/GHC/Utils/Binary.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/ghc.cabal.in
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/exts/rank_polymorphism.rst
- docs/users_guide/exts/static_pointers.rst
- docs/users_guide/using-optimisation.rst
- ghc/GHCi/UI.hs
- hadrian/bindist/Makefile
- hadrian/cabal.project
- hadrian/src/Rules.hs
- hadrian/src/Rules/BinaryDist.hs
- libraries/base/changelog.md
- libraries/base/src/System/Environment.hs
- libraries/base/tests/T15349.stderr
- + libraries/ghc-heap/tests/T27465.hs
- + libraries/ghc-heap/tests/T27465.stdout
- libraries/ghc-heap/tests/all.T
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- libraries/ghc-internal/tests/backtraces/T14532b.stdout
- nofib
- rts/Apply.cmm
- rts/Capability.c
- rts/ContinuationOps.cmm
- rts/PrimOps.cmm
- testsuite/driver/junit.py
- testsuite/driver/perf_notes.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/driver/testutil.py
- testsuite/tests/backpack/should_compile/T13149.bkp
- testsuite/tests/cmm/should_run/AtomicFetch.hs
- testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
- testsuite/tests/codeGen/should_run/cgrun025.stderr
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/determinism/determ017/A.hs
- testsuite/tests/exceptions/T26759.stderr
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/ghc-e/should_fail/T18441fail7.stderr
- testsuite/tests/ghci/scripts/T12005.script
- testsuite/tests/ghci/scripts/bytecodeIPE.hs
- testsuite/tests/ghci/should_run/Makefile
- + testsuite/tests/ghci/should_run/T27287.hs
- + testsuite/tests/ghci/should_run/T27287.stdout
- testsuite/tests/ghci/should_run/all.T
- testsuite/tests/haddock/perf/Fold.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/indexed-types/should_fail/T7354.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/layout/layout001.stdout
- testsuite/tests/layout/layout002.stdout
- testsuite/tests/layout/layout003.stdout
- testsuite/tests/layout/layout004.stdout
- testsuite/tests/layout/layout005.stdout
- testsuite/tests/layout/layout006.stdout
- testsuite/tests/layout/layout007.stdout
- testsuite/tests/layout/layout008.stdout
- testsuite/tests/layout/layout009.stdout
- testsuite/tests/linear/should_compile/T1735Min.hs
- testsuite/tests/mdo/should_fail/mdofail006.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- + testsuite/tests/parser/should_compile/T13087.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_fail/T8431.stderr
- testsuite/tests/parser/should_fail/readFail038.stderr
- testsuite/tests/perf/compiler/T3064.hs
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/perf/compiler/genManyBasicBlocks
- + testsuite/tests/pmcheck/should_compile/T27360.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/polykinds/T7594.hs
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/programs/thurston-modular-arith/Main.hs
- + testsuite/tests/rts/T27123.hs
- testsuite/tests/rts/all.T
- testsuite/tests/rts/ipe/IpeStats/Fold.hs
- testsuite/tests/runghc/T7859.stderr-mingw32
- testsuite/tests/simplCore/should_compile/T11562.hs
- testsuite/tests/simplCore/should_run/T3591.hs
- testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs
- testsuite/tests/typecheck/should_compile/T12507.hs
- testsuite/tests/typecheck/should_compile/T13951.hs
- testsuite/tests/typecheck/should_compile/T15242.stderr
- testsuite/tests/typecheck/should_compile/T18920.hs
- testsuite/tests/typecheck/should_compile/T2595.hs
- testsuite/tests/typecheck/should_compile/T7541.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T6069.stderr
- testsuite/tests/typecheck/should_fail/T7368a.hs
- testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs
- testsuite/tests/typecheck/should_run/T3731-short.hs
- testsuite/tests/typecheck/should_run/T3731.hs
- testsuite/tests/typecheck/should_run/church.hs
- testsuite/tests/typecheck/should_run/tcrun008.hs
- testsuite/tests/typecheck/should_run/tcrun017.hs
- testsuite/tests/typecheck/should_run/tcrun026.hs
- testsuite/tests/typecheck/should_run/tcrun035.hs
- testsuite/tests/typecheck/should_run/tcrun036.hs
- 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/1e8d118c52151c580f5024a5fe0114…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e8d118c52151c580f5024a5fe0114…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/romes/27461] Organize and clean-up GHC.Driver.Downsweep
by Rodrigo Mesquita (＠alt-romes) 17 Jul '26
by Rodrigo Mesquita (＠alt-romes) 17 Jul '26
17 Jul '26
Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC
Commits:
25ec3570 by Rodrigo Mesquita at 2026-07-17T16:21:47+01:00
Organize and clean-up GHC.Driver.Downsweep
Simply some cosmetic changes, moving definitions around to structure the
module better into its relevant sections
(In go (ns ++ ss), it's not a problem to use ++ because it's a good
producer and we won't have to append fully before processing the next
item in go)
- - - - -
1 changed file:
- compiler/GHC/Driver/Downsweep.hs
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -5,8 +5,8 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FunctionalDependencies #-}
+
+-- | See Note [Downsweep and the ModuleGraph]
module GHC.Driver.Downsweep
( downsweep
, downsweepThunk
@@ -119,15 +119,38 @@ import qualified Data.List.NonEmpty as NE
{-
Note [Downsweep and the ModuleGraph]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'ModuleGraph' stores the relationship between all the modules, units, and
+instantiations in the current session, allowing e.g. to answer questions about
+the transitive closure of the imports.
+
+Downsweep is the compiler pass which discovers and builds a new 'ModuleGraph'.
+by following all the (module,unit,...) dependencies, starting from the root modules.
+
+Downsweep iteratively *expands* each so-called 'DownsweepNode' into a list of
+its dependencies, and recursively traverses all reachable nodes in a
+depth-first order using 'dfsBuild'. A 'DownsweepNode' is *expanded* by 'dsNodeExpand':
+
+ dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
-The ModuleGraph stores the relationship between all the modules, units, and
-instantiations in the current session.
+Most notably:
-When we do downsweep, we build up a new ModuleGraph, starting from the root
-modules. By following all the dependencies we construct a graph which allows
-us to answer questions about the transitive closure of the imports.
+ - 'DSMod' (Module-based) nodes can be expanded by preprocessing and
+ parsing the module header, then listing the imports (direct and SOURCE imports)
+ (see 'expandModuleSummary' and 'expandFixedModuleNode')
-The module graph is accessible in the HscEnv.
+ - 'DSUnit' is expanded by finding the unit dependencies of that unit by id
+ (see 'expandUnitNode').
+
+Besides its dependencies, expanding a 'DownsweepNode' produces a
+'ModuleGraphNode'. The final 'ModuleGraph' is constructed from the list of
+'ModuleGraphNode's accumulated by expanding all reachable 'DownsweepNode's.
+
+A 'ModuleGraphNode' is essentially the resolved version of 'DownsweepNode':
+it records the payload (e.g. a Module) *and* its dependencies, unlike
+'DownsweepNode' which has the just the payload that is used as a seed (and
+potentially some context information, like the current home-unit)
+
+TL;DR: We recursively traverse 'DownsweepNodes' to discover and build the 'ModuleGraph'.
When is this graph constructed?
@@ -148,6 +171,9 @@ See also Note [Downsweep Control Flow and Caching]
-}
-----------------------------------------------------------------------------
+-- * Top-level entry to downsweep
+-----------------------------------------------------------------------------
+
--
-- | Downsweep (dependency analysis) for --make mode
--
@@ -159,7 +185,7 @@ See also Note [Downsweep Control Flow and Caching]
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
--- Downsweeping can start from scratch for from a given module graph. In the
+-- Downsweeping can start from scratch or from a given module graph. In the
-- latter case, the given graph is fully included in the resulting graph, even
-- if parts of it are not reachable from any of the given roots. When an import
-- is processed, the source of the imported module is not consulted if this
@@ -175,6 +201,8 @@ See also Note [Downsweep Control Flow and Caching]
--
-- It will also turn on code generation for any modules that need it by calling
-- 'enableCodeGenForTH'.
+--
+-- See also Note [Downsweep and the ModuleGraph]
downsweep :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
@@ -231,6 +259,35 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
unitModuleNodes summaries uid hue =
maybeToList (linkNodes summaries uid hue)
+ -- The linking plan for each module. If we need to do linking for a home unit
+ -- then this function returns a graph node which depends on all the modules in the home unit.
+
+ -- At the moment nothing can depend on these LinkNodes.
+ linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
+ linkNodes summaries uid hue =
+ let dflags = homeUnitEnv_dflags hue
+ ofile = outputFile_ dflags
+
+ unit_nodes :: [NodeKey]
+ unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ no_hs_main = gopt Opt_NoHsMain dflags
+
+ main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
+
+ do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
+
+ in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
+ Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
+ -- This should be an error, not a warning (#10895).
+ | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
+ | otherwise -> Nothing
+
-- | Calculate the module graph starting from a single ModSummary. The result is a
-- thunk, which when forced will perform the downsweep. This is useful in oneshot
-- mode where the module graph may never be needed.
@@ -322,7 +379,35 @@ downsweepInstalledModules hsc_env mods = do
return (mkModuleGraph mg)
+-----------------------------------------------------------------------------
+-- * Orchestrator: downsweepFromRootNodes
+-----------------------------------------------------------------------------
+
+type ModSummaryCache = IORef ModSummaryCacheMap
+type ImportsCache = IORef ImportsCacheMap
+
+-- | A cache from file paths to the already summarised modules. The same file
+-- can be used in multiple units so the map is actually also keyed by which
+-- unit the file was used in.
+--
+-- We want to reuse ModSummaries as far as possible because the most expensive
+-- part of downsweep is reading and parsing the headers.
+--
+-- See Note [Downsweep Control Flow and Caching]
+type ModSummaryCacheMap
+ -- The cache can't be keyed by 'Module' because that isn't sufficient to
+ -- distinguish .hs from .hs-boot files. Use path+unit instead.
+ = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
+-- | A 'ModSummary's provenance during downsweep: an old previously constructed
+-- ModSummary, that might be potentially outdated, or a freshly constructed one
+-- during this downsweep which is certainly up to date?
+data SummProvenance
+ -- | Constructed during this downsweep: trivially up to date
+ = SummFresh
+ -- | Carried over from a previous run: may be stale, must be hash-checked
+ -- (and considered by -fforce-recomp)
+ | SummOld
-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
-- by --make mode, and fixed nodes by oneshot mode.
@@ -381,20 +466,15 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods
[ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s])
| s <- root_nodes ]
- moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey (MGRes ModuleGraphNode)
+ moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey (NodeRes ModuleGraphNode)
moduleGraphNodeMap graph
= M.fromList [(mkNodeKey node, NSuccess node) | node <- mgModSummaries' graph]
sec = initSourceErrorContext (hsc_dflags hsc_env)
-calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
-calcDeps ms =
- -- Add a dependency on the HsBoot file if it exists
- -- This gets passed to the loopImports function which just ignores it if it
- -- can't be found.
- [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
- [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
-
+--------------------------------------------------------------------------------
+-- ** 'DownsweepM'
+--------------------------------------------------------------------------------
type DownsweepM a = ReaderT DownsweepEnv IO a
data DownsweepEnv = DownsweepEnv {
@@ -405,29 +485,6 @@ data DownsweepEnv = DownsweepEnv {
, _downsweep_excl_mods :: [ModuleName]
}
-type ModSummaryCache = IORef ModSummaryCacheMap
-type ImportsCache = IORef ImportsCacheMap
-
--- | A cache from file paths to the already summarised modules. The same file
--- can be used in multiple units so the map is actually also keyed by which
--- unit the file was used in.
---
--- We want to reuse ModSummaries as far as possible because the most expensive
--- part of downsweep is reading and parsing the headers.
---
--- See Note [Downsweep Control Flow and Caching]
-type ModSummaryCacheMap
- -- The cache can't be keyed by 'Module' because that isn't sufficient to
- -- distinguish .hs from .hs-boot files. Use path+unit instead.
- = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
-
-data SummProvenance
- -- | Constructed during this downsweep: trivially up to date
- = SummFresh
- -- | Carried over from a previous run: may be stale, must be hash-checked
- -- (and considered by -fforce-recomp)
- | SummOld
-
mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs
@@ -460,17 +517,19 @@ mkRootMap summaries = Map.fromList
runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
runDownsweepM env act = runReaderT act env
-loopDownsweepNodes :: M.Map NodeKey (MGRes ModuleGraphNode) -> [DownsweepNode] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopModuleNodeInfos :: M.Map NodeKey (MGRes ModuleGraphNode) -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopUnits :: M.Map NodeKey (MGRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopInstantiations :: M.Map NodeKey (MGRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopFromInteractive :: M.Map NodeKey (MGRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
+loopDownsweepNodes :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [DownsweepNode] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopModuleNodeInfos :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopUnits :: M.Map NodeKey (NodeRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopInstantiations :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopFromInteractive :: M.Map NodeKey (NodeRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod
loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst)
loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m
+--------------------------------------------------------------------------------
+-- * Expanding 'DownsweepNode's into payload and node dependencies
--------------------------------------------------------------------------------
-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
@@ -516,7 +575,7 @@ dsNodeInfoKey = \case
DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud
DSInteractive mod _imps -> NodeKey_Module $ moduleToMnk mod NotBoot
-dsNodeExpand :: DownsweepNode -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
dsNodeExpand = \case
DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms
DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc
@@ -525,12 +584,29 @@ dsNodeExpand = \case
, home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid
DSInteractive imod iis -> expandInteractiveImports imod iis
-expandModuleSummary :: ModSummary -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandModuleSummary :: ModSummary -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
hsc_env <- asks downsweep_hsc_env
let home_uid = ms_unitid ms
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do
+ (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms)
+
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ boot_todo <-
+ if | HsBootFile <- ms_hsc_src ms
+ -> do
+ r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
+ case r of
+ FoundHome s -> pure [DSMod s]
+ _ -> pure []
+ | otherwise -> pure []
+
+ return $ NSuccess
+ ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
+ , boot_todo ++ concat todo
+ )
+ where
+ expandModImport home_uid home_unit (imp,mb_pkg,gwib) = do
let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing
@@ -552,24 +628,17 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do
( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))
, [DSMod s] )
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- boot_todo <-
- if | HsBootFile <- ms_hsc_src ms
- -> do
- r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
- case r of
- FoundHome s -> pure [DSMod s]
- _ -> pure []
- | otherwise -> pure []
-
- return $ NSuccess
- ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
- , boot_todo ++ concat todo
- )
+ calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ calcDeps ms =
+ -- Add a dependency on the HsBoot file if it exists
+ -- This gets passed to the loopImports function which just ignores it if it
+ -- can't be found.
+ [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
+ [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
-- | Expand a 'ModuleNodeFixed' node
-- NB: If you ever reach a Fixed node, everything under that also must be fixed.
-expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandFixedModuleNode key loc = do
hsc_env <- asks downsweep_hsc_env
-- MP: TODO, we should just read the dependency info from the interface rather than either
@@ -603,7 +672,7 @@ expandFixedModuleNode key loc = do
pure $ Just $ DSMod (ModuleNodeFixed key loc)
_otherwise ->
-- If the finder fails, just keep going, there will be another
- -- error later.
+ -- error later when we try to expand this dependency.
pure Nothing
mk_dep _ (Right uid_dep) = do
-- Set active unit so that looking loopUnit finds the correct
@@ -611,9 +680,22 @@ expandFixedModuleNode key loc = do
let home_uid = mnkUnitId key
pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
+ mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
+ mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
+ mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+
+ ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
+ ifaceDeps deps =
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
+ ] ++
+ [ Right (tcImportLevel lvl, uid)
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
+ ]
+
-- | Expand a unit id under the context of a certain home unit
expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
- -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+ -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandUnitNode node_uid home_context_uid = do
-- Set active unit so that looking loopUnit finds the correct
-- -package flags in the unit state.
@@ -623,12 +705,12 @@ expandUnitNode node_uid home_context_uid = do
Just us -> pure $ NSuccess ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)
-expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandInstantiatedUnit iud home_uid = pure $ NSuccess
( InstantiationNode home_uid iud
, [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )
-expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandInteractiveImports imod imps = do
hsc_env <- asks downsweep_hsc_env
imps_cache <- asks downsweep_imports_cache
@@ -686,19 +768,8 @@ expandInteractiveImports imod imps = do
node_type = ModuleNodeFixed key ml
--------------------------------------------------------------------------------
-
-mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
-mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
-mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
-
-ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
-ifaceDeps deps =
- [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
- | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
- ] ++
- [ Right (tcImportLevel lvl, uid)
- | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
- ]
+-- * Constructing Module Summaries
+--------------------------------------------------------------------------------
downsweepSummarise :: HomeUnit
-> IsBootInterface
@@ -745,35 +816,6 @@ instantiationNodes uid unit_state = map (uid,) iuids_to_check
, recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
]
--- The linking plan for each module. If we need to do linking for a home unit
--- then this function returns a graph node which depends on all the modules in the home unit.
-
--- At the moment nothing can depend on these LinkNodes.
-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
-linkNodes summaries uid hue =
- let dflags = homeUnitEnv_dflags hue
- ofile = outputFile_ dflags
-
- unit_nodes :: [NodeKey]
- unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
- -- Issue a warning for the confusing case where the user
- -- said '-o foo' but we're not going to do any linking.
- -- We attempt linking if either (a) one of the modules is
- -- called Main, or (b) the user said -no-hs-main, indicating
- -- that main() is going to come from somewhere else.
- --
- no_hs_main = gopt Opt_NoHsMain dflags
-
- main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
-
- do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
-
- in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
- Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
- -- This should be an error, not a warning (#10895).
- | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
- | otherwise -> Nothing
-
getRootSummary ::
[ModuleName] ->
ModSummaryCache ->
@@ -858,6 +900,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
throwIO e
a -> pure a
+--------------------------------------------------------------------------------
+-- * Check/validate properties and error out
+--------------------------------------------------------------------------------
+
-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
--
@@ -905,6 +951,10 @@ checkHomeUnitsClosed ue
let todo'' = (depends Set.\\ done) `Set.union` todo'
in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
+--------------------------------------------------------------------------------
+-- * Enable Code Gen for Template Haskell
+--------------------------------------------------------------------------------
+
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
@@ -1223,7 +1273,8 @@ Potential TODOS:
-}
-----------------------------------------------------------------------------
--- Summarising modules
+-- * Pre-processing and Summarising and modules
+-----------------------------------------------------------------------------
-- We have two types of summarisation:
--
@@ -1639,9 +1690,11 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
return PreprocessedImports {..}
--------------------------------------------------------------------------------
+-- * Generic traversal of iteratively-built graph: dfsBuild
+--------------------------------------------------------------------------------
-- | The result of expanding a node in 'dfsBuild'.
-data MGRes v
+data NodeRes v
-- | Computed the node payload successfully
= NSuccess v
-- | Skip a node! This means this node doesn't produce a payload and we can
@@ -1657,8 +1710,8 @@ data MGRes v
-- graph by iteratively expanding a node into a payload and a list of children
-- nodes to visit next.
--
--- A node is NEVER visited/expanded more than once, as long as the the
--- node key @k@, computed from the node @n@, uniquely identifies that node.
+-- A node is NEVER visited/expanded more than once, as long as the node key
+-- @k@, computed from the node @n@, uniquely identifies that node.
--
-- The first argument @base_map@ is the starting set of already visited nodes
-- (these nodes won't be expanded again!).
@@ -1678,17 +1731,17 @@ data MGRes v
--
-- See also Note [Downsweep Control Flow and Caching]
dfsBuild :: (Ord k, Monad m)
- => Maybe (Map.Map k (MGRes v))
+ => Maybe (Map.Map k (NodeRes v))
-- ^ Base map, existing results. We won't re-expand any of the nodes
-- already present in this map.
-> [n]
-- ^ The root nodes from where to start traversal
-> (n -> k)
-- ^ Compute the key which uniquely identifies this node
- -> (n -> m (MGRes (v,[n])))
+ -> (n -> m (NodeRes (v,[n])))
-- ^ Expand this node into its payload result and into the list of
-- children nodes to visit next.
- -> m (Map.Map k (MGRes v))
+ -> m (Map.Map k (NodeRes v))
-- ^ The result accumulates the payload of expanding the root nodes
-- and all nodes transitively reachable from those roots.
dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
@@ -1704,7 +1757,7 @@ dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
go ss
(Map.insert k NSkip visited) -- Skip!
NSuccess (v,ns) ->
- go (ns ++ ss {- todo: not use ++ here? -})
+ go (ns ++ ss)
(Map.insert k (NSuccess v) visited)
where
k = key s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25ec3570556d915af9e5c1c97daa25c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25ec3570556d915af9e5c1c97daa25c…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/romes/27461] Organize and clean-up GHC.Driver.Downsweep
by Rodrigo Mesquita (＠alt-romes) 17 Jul '26
by Rodrigo Mesquita (＠alt-romes) 17 Jul '26
17 Jul '26
Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC
Commits:
1dfb0225 by Rodrigo Mesquita at 2026-07-17T16:20:42+01:00
Organize and clean-up GHC.Driver.Downsweep
Simply some cosmetic changes, moving definitions around to structure the
module better into its relevant sections
(In go (ns ++ ss), it's not a problem to use ++ because it's a good
producer and we won't have to append fully before processing the next
item in go)
- - - - -
1 changed file:
- compiler/GHC/Driver/Downsweep.hs
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -5,8 +5,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FunctionalDependencies #-}
module GHC.Driver.Downsweep
( downsweep
, downsweepThunk
@@ -119,15 +117,38 @@ import qualified Data.List.NonEmpty as NE
{-
Note [Downsweep and the ModuleGraph]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'ModuleGraph' stores the relationship between all the modules, units, and
+instantiations in the current session, allowing e.g. to answer questions about
+the transitive closure of the imports.
-The ModuleGraph stores the relationship between all the modules, units, and
-instantiations in the current session.
+Downsweep is the compiler pass which discovers and builds a new 'ModuleGraph'.
+by following all the (module,unit,...) dependencies, starting from the root modules.
-When we do downsweep, we build up a new ModuleGraph, starting from the root
-modules. By following all the dependencies we construct a graph which allows
-us to answer questions about the transitive closure of the imports.
+Downsweep iteratively *expands* each so-called 'DownsweepNode' into a list of
+its dependencies, and recursively traverses all reachable nodes in a
+depth-first order using 'dfsBuild'. A 'DownsweepNode' is *expanded* by 'dsNodeExpand':
-The module graph is accessible in the HscEnv.
+ dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+
+Most notably:
+
+ - 'DSMod' (Module-based) nodes can be expanded by preprocessing and
+ parsing the module header, then listing the imports (direct and SOURCE imports)
+ (see 'expandModuleSummary' and 'expandFixedModuleNode')
+
+ - 'DSUnit' is expanded by finding the unit dependencies of that unit by id
+ (see 'expandUnitNode').
+
+Besides its dependencies, expanding a 'DownsweepNode' produces a
+'ModuleGraphNode'. The final 'ModuleGraph' is constructed from the list of
+'ModuleGraphNode's accumulated by expanding all reachable 'DownsweepNode's.
+
+A 'ModuleGraphNode' is essentially the resolved version of 'DownsweepNode':
+it records the payload (e.g. a Module) *and* its dependencies, unlike
+'DownsweepNode' which has the just the payload that is used as a seed (and
+potentially some context information, like the current home-unit)
+
+TL;DR: We recursively traverse 'DownsweepNodes' to discover and build the 'ModuleGraph'.
When is this graph constructed?
@@ -148,6 +169,9 @@ See also Note [Downsweep Control Flow and Caching]
-}
-----------------------------------------------------------------------------
+-- * Top-level entry to downsweep
+-----------------------------------------------------------------------------
+
--
-- | Downsweep (dependency analysis) for --make mode
--
@@ -159,7 +183,7 @@ See also Note [Downsweep Control Flow and Caching]
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
--- Downsweeping can start from scratch for from a given module graph. In the
+-- Downsweeping can start from scratch or from a given module graph. In the
-- latter case, the given graph is fully included in the resulting graph, even
-- if parts of it are not reachable from any of the given roots. When an import
-- is processed, the source of the imported module is not consulted if this
@@ -231,6 +255,35 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
unitModuleNodes summaries uid hue =
maybeToList (linkNodes summaries uid hue)
+ -- The linking plan for each module. If we need to do linking for a home unit
+ -- then this function returns a graph node which depends on all the modules in the home unit.
+
+ -- At the moment nothing can depend on these LinkNodes.
+ linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
+ linkNodes summaries uid hue =
+ let dflags = homeUnitEnv_dflags hue
+ ofile = outputFile_ dflags
+
+ unit_nodes :: [NodeKey]
+ unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ no_hs_main = gopt Opt_NoHsMain dflags
+
+ main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
+
+ do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
+
+ in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
+ Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
+ -- This should be an error, not a warning (#10895).
+ | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
+ | otherwise -> Nothing
+
-- | Calculate the module graph starting from a single ModSummary. The result is a
-- thunk, which when forced will perform the downsweep. This is useful in oneshot
-- mode where the module graph may never be needed.
@@ -322,7 +375,35 @@ downsweepInstalledModules hsc_env mods = do
return (mkModuleGraph mg)
+-----------------------------------------------------------------------------
+-- * Orchestrator: downsweepFromRootNodes
+-----------------------------------------------------------------------------
+type ModSummaryCache = IORef ModSummaryCacheMap
+type ImportsCache = IORef ImportsCacheMap
+
+-- | A cache from file paths to the already summarised modules. The same file
+-- can be used in multiple units so the map is actually also keyed by which
+-- unit the file was used in.
+--
+-- We want to reuse ModSummaries as far as possible because the most expensive
+-- part of downsweep is reading and parsing the headers.
+--
+-- See Note [Downsweep Control Flow and Caching]
+type ModSummaryCacheMap
+ -- The cache can't be keyed by 'Module' because that isn't sufficient to
+ -- distinguish .hs from .hs-boot files. Use path+unit instead.
+ = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
+
+-- | A 'ModSummary's provenance during downsweep: an old previously constructed
+-- ModSummary, that might be potentially outdated, or a freshly constructed one
+-- during this downsweep which is certainly up to date?
+data SummProvenance
+ -- | Constructed during this downsweep: trivially up to date
+ = SummFresh
+ -- | Carried over from a previous run: may be stale, must be hash-checked
+ -- (and considered by -fforce-recomp)
+ | SummOld
-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
-- by --make mode, and fixed nodes by oneshot mode.
@@ -381,20 +462,15 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods
[ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s])
| s <- root_nodes ]
- moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey (MGRes ModuleGraphNode)
+ moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey (NodeRes ModuleGraphNode)
moduleGraphNodeMap graph
= M.fromList [(mkNodeKey node, NSuccess node) | node <- mgModSummaries' graph]
sec = initSourceErrorContext (hsc_dflags hsc_env)
-calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
-calcDeps ms =
- -- Add a dependency on the HsBoot file if it exists
- -- This gets passed to the loopImports function which just ignores it if it
- -- can't be found.
- [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
- [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
-
+--------------------------------------------------------------------------------
+-- ** 'DownsweepM'
+--------------------------------------------------------------------------------
type DownsweepM a = ReaderT DownsweepEnv IO a
data DownsweepEnv = DownsweepEnv {
@@ -405,29 +481,6 @@ data DownsweepEnv = DownsweepEnv {
, _downsweep_excl_mods :: [ModuleName]
}
-type ModSummaryCache = IORef ModSummaryCacheMap
-type ImportsCache = IORef ImportsCacheMap
-
--- | A cache from file paths to the already summarised modules. The same file
--- can be used in multiple units so the map is actually also keyed by which
--- unit the file was used in.
---
--- We want to reuse ModSummaries as far as possible because the most expensive
--- part of downsweep is reading and parsing the headers.
---
--- See Note [Downsweep Control Flow and Caching]
-type ModSummaryCacheMap
- -- The cache can't be keyed by 'Module' because that isn't sufficient to
- -- distinguish .hs from .hs-boot files. Use path+unit instead.
- = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
-
-data SummProvenance
- -- | Constructed during this downsweep: trivially up to date
- = SummFresh
- -- | Carried over from a previous run: may be stale, must be hash-checked
- -- (and considered by -fforce-recomp)
- | SummOld
-
mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs
@@ -460,17 +513,19 @@ mkRootMap summaries = Map.fromList
runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
runDownsweepM env act = runReaderT act env
-loopDownsweepNodes :: M.Map NodeKey (MGRes ModuleGraphNode) -> [DownsweepNode] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopModuleNodeInfos :: M.Map NodeKey (MGRes ModuleGraphNode) -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopUnits :: M.Map NodeKey (MGRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopInstantiations :: M.Map NodeKey (MGRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
-loopFromInteractive :: M.Map NodeKey (MGRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (MGRes ModuleGraphNode))
+loopDownsweepNodes :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [DownsweepNode] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopModuleNodeInfos :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopUnits :: M.Map NodeKey (NodeRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopInstantiations :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopFromInteractive :: M.Map NodeKey (NodeRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod
loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst)
loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m
+--------------------------------------------------------------------------------
+-- * Expanding 'DownsweepNode's into payload and node dependencies
--------------------------------------------------------------------------------
-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
@@ -516,7 +571,7 @@ dsNodeInfoKey = \case
DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud
DSInteractive mod _imps -> NodeKey_Module $ moduleToMnk mod NotBoot
-dsNodeExpand :: DownsweepNode -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
dsNodeExpand = \case
DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms
DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc
@@ -525,12 +580,29 @@ dsNodeExpand = \case
, home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid
DSInteractive imod iis -> expandInteractiveImports imod iis
-expandModuleSummary :: ModSummary -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandModuleSummary :: ModSummary -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
hsc_env <- asks downsweep_hsc_env
let home_uid = ms_unitid ms
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do
+ (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms)
+
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ boot_todo <-
+ if | HsBootFile <- ms_hsc_src ms
+ -> do
+ r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
+ case r of
+ FoundHome s -> pure [DSMod s]
+ _ -> pure []
+ | otherwise -> pure []
+
+ return $ NSuccess
+ ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
+ , boot_todo ++ concat todo
+ )
+ where
+ expandModImport home_uid home_unit (imp,mb_pkg,gwib) = do
let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing
@@ -552,24 +624,17 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do
( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))
, [DSMod s] )
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- boot_todo <-
- if | HsBootFile <- ms_hsc_src ms
- -> do
- r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
- case r of
- FoundHome s -> pure [DSMod s]
- _ -> pure []
- | otherwise -> pure []
-
- return $ NSuccess
- ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
- , boot_todo ++ concat todo
- )
+ calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ calcDeps ms =
+ -- Add a dependency on the HsBoot file if it exists
+ -- This gets passed to the loopImports function which just ignores it if it
+ -- can't be found.
+ [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
+ [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
-- | Expand a 'ModuleNodeFixed' node
-- NB: If you ever reach a Fixed node, everything under that also must be fixed.
-expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandFixedModuleNode key loc = do
hsc_env <- asks downsweep_hsc_env
-- MP: TODO, we should just read the dependency info from the interface rather than either
@@ -603,7 +668,7 @@ expandFixedModuleNode key loc = do
pure $ Just $ DSMod (ModuleNodeFixed key loc)
_otherwise ->
-- If the finder fails, just keep going, there will be another
- -- error later.
+ -- error later when we try to expand this dependency.
pure Nothing
mk_dep _ (Right uid_dep) = do
-- Set active unit so that looking loopUnit finds the correct
@@ -611,9 +676,22 @@ expandFixedModuleNode key loc = do
let home_uid = mnkUnitId key
pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
+ mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
+ mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
+ mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+
+ ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
+ ifaceDeps deps =
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
+ ] ++
+ [ Right (tcImportLevel lvl, uid)
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
+ ]
+
-- | Expand a unit id under the context of a certain home unit
expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
- -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+ -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandUnitNode node_uid home_context_uid = do
-- Set active unit so that looking loopUnit finds the correct
-- -package flags in the unit state.
@@ -623,12 +701,12 @@ expandUnitNode node_uid home_context_uid = do
Just us -> pure $ NSuccess ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)
-expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandInstantiatedUnit iud home_uid = pure $ NSuccess
( InstantiationNode home_uid iud
, [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )
-expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
+expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
expandInteractiveImports imod imps = do
hsc_env <- asks downsweep_hsc_env
imps_cache <- asks downsweep_imports_cache
@@ -686,19 +764,8 @@ expandInteractiveImports imod imps = do
node_type = ModuleNodeFixed key ml
--------------------------------------------------------------------------------
-
-mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
-mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
-mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
-
-ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
-ifaceDeps deps =
- [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
- | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
- ] ++
- [ Right (tcImportLevel lvl, uid)
- | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
- ]
+-- * Constructing Module Summaries
+--------------------------------------------------------------------------------
downsweepSummarise :: HomeUnit
-> IsBootInterface
@@ -745,35 +812,6 @@ instantiationNodes uid unit_state = map (uid,) iuids_to_check
, recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
]
--- The linking plan for each module. If we need to do linking for a home unit
--- then this function returns a graph node which depends on all the modules in the home unit.
-
--- At the moment nothing can depend on these LinkNodes.
-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
-linkNodes summaries uid hue =
- let dflags = homeUnitEnv_dflags hue
- ofile = outputFile_ dflags
-
- unit_nodes :: [NodeKey]
- unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
- -- Issue a warning for the confusing case where the user
- -- said '-o foo' but we're not going to do any linking.
- -- We attempt linking if either (a) one of the modules is
- -- called Main, or (b) the user said -no-hs-main, indicating
- -- that main() is going to come from somewhere else.
- --
- no_hs_main = gopt Opt_NoHsMain dflags
-
- main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
-
- do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
-
- in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
- Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
- -- This should be an error, not a warning (#10895).
- | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
- | otherwise -> Nothing
-
getRootSummary ::
[ModuleName] ->
ModSummaryCache ->
@@ -858,6 +896,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
throwIO e
a -> pure a
+--------------------------------------------------------------------------------
+-- * Check/validate properties and error out
+--------------------------------------------------------------------------------
+
-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
--
@@ -905,6 +947,10 @@ checkHomeUnitsClosed ue
let todo'' = (depends Set.\\ done) `Set.union` todo'
in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
+--------------------------------------------------------------------------------
+-- * Enable Code Gen for Template Haskell
+--------------------------------------------------------------------------------
+
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
@@ -1223,7 +1269,8 @@ Potential TODOS:
-}
-----------------------------------------------------------------------------
--- Summarising modules
+-- * Pre-processing and Summarising and modules
+-----------------------------------------------------------------------------
-- We have two types of summarisation:
--
@@ -1639,9 +1686,11 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
return PreprocessedImports {..}
--------------------------------------------------------------------------------
+-- * Generic traversal of iteratively-built graph: dfsBuild
+--------------------------------------------------------------------------------
-- | The result of expanding a node in 'dfsBuild'.
-data MGRes v
+data NodeRes v
-- | Computed the node payload successfully
= NSuccess v
-- | Skip a node! This means this node doesn't produce a payload and we can
@@ -1657,8 +1706,8 @@ data MGRes v
-- graph by iteratively expanding a node into a payload and a list of children
-- nodes to visit next.
--
--- A node is NEVER visited/expanded more than once, as long as the the
--- node key @k@, computed from the node @n@, uniquely identifies that node.
+-- A node is NEVER visited/expanded more than once, as long as the node key
+-- @k@, computed from the node @n@, uniquely identifies that node.
--
-- The first argument @base_map@ is the starting set of already visited nodes
-- (these nodes won't be expanded again!).
@@ -1678,17 +1727,17 @@ data MGRes v
--
-- See also Note [Downsweep Control Flow and Caching]
dfsBuild :: (Ord k, Monad m)
- => Maybe (Map.Map k (MGRes v))
+ => Maybe (Map.Map k (NodeRes v))
-- ^ Base map, existing results. We won't re-expand any of the nodes
-- already present in this map.
-> [n]
-- ^ The root nodes from where to start traversal
-> (n -> k)
-- ^ Compute the key which uniquely identifies this node
- -> (n -> m (MGRes (v,[n])))
+ -> (n -> m (NodeRes (v,[n])))
-- ^ Expand this node into its payload result and into the list of
-- children nodes to visit next.
- -> m (Map.Map k (MGRes v))
+ -> m (Map.Map k (NodeRes v))
-- ^ The result accumulates the payload of expanding the root nodes
-- and all nodes transitively reachable from those roots.
dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
@@ -1704,7 +1753,7 @@ dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
go ss
(Map.insert k NSkip visited) -- Skip!
NSuccess (v,ns) ->
- go (ns ++ ss {- todo: not use ++ here? -})
+ go (ns ++ ss)
(Map.insert k (NSuccess v) visited)
where
k = key s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dfb022596c25087815141438c3ea00…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dfb022596c25087815141438c3ea00…
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] 23 commits: Mark various language extension flags as deprecated (see #27329)
by Marge Bot (＠marge-bot) 17 Jul '26
by Marge Bot (＠marge-bot) 17 Jul '26
17 Jul '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00
Mark various language extension flags as deprecated (see #27329)
The following language extensions are now deprecated:
- AlternativeLayoutRule
- AlternativeLayoutRuleTransitional
- ParallelArrays
- PolymorphicComponents
- Rank2Types
In addition, the warning `-Walternative-layout-rule-transitional`
has been marked as deprecated, as it is emitted only under the
deprecated extension `XAlternativeLayoutRuleTransitional`.
- - - - -
fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00
base: re-export GHC.Environment.getFullArgs from System.Environment
CLC proposal https://github.com/haskell/core-libraries-committee/issues/431
- - - - -
9638ee97 by sheaf at 2026-07-17T10:37:56-04:00
Coercion optimisation: avoid double-Sym for InstCo
Ticket #27374 pointed out an issue with GHC.Core.Coercion.Opt.optCoercion's
handling of InstCo: it contravened (LC2) in Note [The LiftingContext in optCoercion]
because it applied the ambient 'sym' to a coercion that was then added
to the lifting context substitution.
Fixes #27374
Co-authored-by: Simon Jakobi <simon.jakobi(a)gmail.com>
- - - - -
76ed2a33 by sheaf at 2026-07-17T10:37:57-04:00
Coercion optimisation: avoid exponential behaviour
The change to coercion optimisation of 'InstCo' in the previous commit
introduces exponential behaviour to the coercion optimiser. To avoid
this, this commit provides a way to push in 'Sym' of an already-optimised
coercion: GHC.Core.Coercion.Opt.mkDeepSymCo.
See Note [Pushing Sym without re-optimising] in GHC.Core.Coercion.Opt.
- - - - -
a2ca719f by Duncan Coutts at 2026-07-17T10:37:57-04:00
Move THREADED_RTS-conditional struct members to end of Capability
Accessing members of the Capability struct from CMM code rely on
accessor macros. (The macros are generated by deriveConstants).
These macros have a single definition. This means that the offsets of
all struct members must *not* vary based on THREADED_RTS vs
!THREADED_RTS. This requires that any struct members that are
conditional on THREADED_RTS must occur after the unconditional struct
members. Hence we move all the ones that are conditional on
THREADED_RTS to the end.
Add a deriveConstants entry for the iomgr member of the Capability
struct, which was the motivation for this change.
Add warning messages to help our future selves. Debugging this took me
a couple hours in gdb!
- - - - -
f2a10d44 by Duncan Coutts at 2026-07-17T10:37:57-04:00
Make the IOManager API use CapIOManager rather than Capability
This makes the API somewhat more self-contained and more consistent.
Now the IOManager API and each of the backends takes just the I/O
manager structure. Previously we had a bit of a mixture, depending on
whether the function needed access to the Capability or just the
CapIOManager.
We still need access to the cap, so we introduce a back reference to
reach the capability, via iomgr->cap.
Convert all uses in select and poll backends, but not win32 ones.
Convert callers in the scheduler and elsewhere.
Also convert the three CMM primops that call IOManager APIs. They just
need to use Capability_iomgr(MyCapability()).
- - - - -
cf89cc9f by Duncan Coutts at 2026-07-17T10:37:57-04:00
Split posix/MIO.c out of posix/Signals.c
The MIO I/O manager was secretly living inside the Signals file.
Now it gets its own file, like any other self-respecting I/O manager.
- - - - -
c13f6135 by Duncan Coutts at 2026-07-17T10:37:57-04:00
Rationalise some scheduler run queue utilities
Move them all to the same place in the file.
Make some static that were used only internally.
Also remove a redundant assignment after calling truncateRunQueue that
is already done within truncateRunQueue.
- - - - -
8f296136 by Duncan Coutts at 2026-07-17T10:37:57-04:00
Rename initIOManager{AfterFork} to {re}startIOManager
These are more accurate names, since these actions happen after
initialisation and are really about starting (or restarting) background
threads.
- - - - -
2bf4bfa5 by Duncan Coutts at 2026-07-17T10:37:57-04:00
Free per-cap I/O managers during shutdown and forkProcess
Historically this was not strictly necessary. The select and win32
legacy I/O managers did not maintain any dynamically allocated
resources. The new poll one does (an auxillary table), and so this
should be freed.
After forkProcess, all threads get deleted. This includes threads
waiting on I/O or timers. So as of this patch, resetting the I/O
manager is just about tidying things up. For example, for the poll
I/O manager this will reset the size of the AIOP table (which
otherwise grows but never shrinks).
In future however the re-initialising will become neeecessary for
functionality, since some I/O managers will need to re-initialise
wakeup fds that are set CLOEXEC.
- - - - -
84b13841 by Duncan Coutts at 2026-07-17T10:37:57-04:00
Add a TODO to the MIO I/O manager
The direction of travel is to make I/O managers per-capability and have
all their state live in the struct CapIOManager. The MIO I/O manager
however still has a number of global variables.
It's not obvious how handle these globals however.
- - - - -
48f74c33 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add a FIXME note in the Poll I/O manager
- - - - -
8da71ff3 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add missing updateRemembSetPushClosure in poll I/O manager
For the non-moving GC.
- - - - -
aa573dde by Duncan Coutts at 2026-07-17T10:37:58-04:00
Minor doc improvement to struct StgAsyncIOOp member outcome
Mention the enumeration names, as well as their numeric values. The rest
of the code uses the enum names.
- - - - -
4b008136 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Minor doc improvements for StgTSOBlockInfo
Clarify that certain union members are used only by certain legacy
I/O managers. Hopefully we will be able to remove these at some point.
- - - - -
773c7819 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Avoid exporting various win32-specific rts symbols
The BeginPrivate.h / EndPrivate.h scheme works perfectly well on
Windows, but all of the rts/win32/*.h files were not using it.
- - - - -
0be3a63d by Duncan Coutts at 2026-07-17T10:37:58-04:00
Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
We no longer need wakeupIOManager for the threaded RTS case, so we can
remove it and the bits only needed to support it. This includes the
pipe/eventfd fd shared between the RTS and the in-library I/O manager
used for waking up the I/O manager thread. The pipe/eventfd still
exists, but it no longer has to be communicated to the RTS, since the
RTS no longer needs to use it.
So we remove the RTS API export setIOManagerWakeupFd, and remove uses of
it within the I/O managers in ghc-internal.
- - - - -
c71f02e2 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add a new interruptIOManager API for the I/O managers
It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the
return type and docs for awaitCompletedTimeoutsOrIO to have it return
false when it gets interrupted, and have no useful post condition in
that case.
- - - - -
a63841a9 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add interruptIOManager support for select I/O manager
Uses the FdWakup mechanism.
- - - - -
68557ea8 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add interruptIOManager support for poll I/O manager
Uses the FdWakup mechanism.
A quirk we have to cope with is that we now need to poll one more fd --
the wakeup_fd_r -- but this fd has no corresponding entry in the
aiop_table. This is awkward since we have set up our aiop_poll_table to
be an auxilliary table with matching indicies.
The solution this patch uses (and described in the comments) is to have
two tables: struct pollfd *aiop_poll_table, *full_poll_table;
and to have the aiop_poll_table alias the tail of the full_poll_table.
The head entry in the full_poll_table is the extra fd. So we poll the
full_poll_table, while the aiop_poll_table still has matching indicies
with the aiop_table.
Hurrah for C aliasing rules.
- - - - -
2b95eb69 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Add interruptIOManager support for win32 legacy I/O manager
And remove unused related helper resetAbandonRequestWait. It is not
called because the event is created in auto-reset mode, so never needs
to be reset manually.
- - - - -
7cbade88 by Duncan Coutts at 2026-07-17T10:37:58-04:00
Note lack of interruptIOManager support for WinIO I/O manager
Though there's a plausible design, we can't sanely test it at the moment
due to related WinIO bugs. Filed as issue #27403.
- - - - -
b45647cc by Duncan Coutts at 2026-07-17T10:37:58-04:00
Be more explicit about enum IOReadOrWrite values, and type within cmm
Belt and braces.
- - - - -
98 changed files:
- + changelog.d/T27329
- + changelog.d/T27374
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Tc/Types/Rank.hs
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/exts/rank_polymorphism.rst
- docs/users_guide/exts/static_pointers.rst
- libraries/base/changelog.md
- libraries/base/src/System/Environment.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/Capability.c
- rts/Capability.h
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/Schedule.h
- rts/include/rts/IOInterface.h
- rts/include/rts/storage/Closures.h
- rts/include/rts/storage/TSO.h
- rts/posix/FdWakeup.h
- + rts/posix/MIO.c
- + rts/posix/MIO.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Select.h
- rts/posix/Signals.c
- rts/posix/Signals.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/rts.cabal
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- rts/win32/AsyncWinIO.h
- rts/win32/AwaitEvent.c
- rts/win32/AwaitEvent.h
- rts/win32/ConsoleHandler.h
- rts/win32/MIOManager.h
- rts/win32/ThrIOManager.h
- rts/win32/WorkQueue.h
- rts/win32/veh_excn.h
- testsuite/tests/backpack/should_compile/T13149.bkp
- + testsuite/tests/corelint/T27374.hs
- testsuite/tests/corelint/all.T
- testsuite/tests/determinism/determ017/A.hs
- testsuite/tests/ghci/scripts/T12005.script
- testsuite/tests/haddock/perf/Fold.hs
- testsuite/tests/indexed-types/should_fail/T7354.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/layout/layout001.stdout
- testsuite/tests/layout/layout002.stdout
- testsuite/tests/layout/layout003.stdout
- testsuite/tests/layout/layout004.stdout
- testsuite/tests/layout/layout005.stdout
- testsuite/tests/layout/layout006.stdout
- testsuite/tests/layout/layout007.stdout
- testsuite/tests/layout/layout008.stdout
- testsuite/tests/layout/layout009.stdout
- testsuite/tests/linear/should_compile/T1735Min.hs
- + testsuite/tests/parser/should_compile/T13087.stderr
- testsuite/tests/parser/should_fail/T8431.stderr
- testsuite/tests/parser/should_fail/readFail038.stderr
- testsuite/tests/perf/compiler/T3064.hs
- testsuite/tests/polykinds/T7594.hs
- testsuite/tests/programs/thurston-modular-arith/Main.hs
- testsuite/tests/rts/ipe/IpeStats/Fold.hs
- testsuite/tests/simplCore/should_compile/T11562.hs
- testsuite/tests/simplCore/should_run/T3591.hs
- testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs
- testsuite/tests/typecheck/should_compile/T12507.hs
- testsuite/tests/typecheck/should_compile/T13951.hs
- testsuite/tests/typecheck/should_compile/T18920.hs
- testsuite/tests/typecheck/should_compile/T2595.hs
- testsuite/tests/typecheck/should_compile/T7541.hs
- testsuite/tests/typecheck/should_fail/T6069.stderr
- testsuite/tests/typecheck/should_fail/T7368a.hs
- testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs
- testsuite/tests/typecheck/should_run/T3731-short.hs
- testsuite/tests/typecheck/should_run/T3731.hs
- testsuite/tests/typecheck/should_run/church.hs
- testsuite/tests/typecheck/should_run/tcrun008.hs
- testsuite/tests/typecheck/should_run/tcrun017.hs
- testsuite/tests/typecheck/should_run/tcrun026.hs
- testsuite/tests/typecheck/should_run/tcrun035.hs
- testsuite/tests/typecheck/should_run/tcrun036.hs
- utils/deriveConstants/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d95741230dd80505fbafcda4861ae…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d95741230dd80505fbafcda4861ae…
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/dcoutts/io-manager-selectbis] 5 commits: Add a new I/O manager based on select()
by Duncan Coutts (＠dcoutts) 17 Jul '26
by Duncan Coutts (＠dcoutts) 17 Jul '26
17 Jul '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-selectbis at Glasgow Haskell Compiler / GHC
Commits:
27711d99 by Duncan Coutts at 2026-07-17T15:04:59+01:00
Add a new I/O manager based on select()
Yes, this is the second such I/O manager, but it is a modern
re-implementation based on the new in-RTS I/O manager infrastructure. So
it is cleaner and faster than the old select I/O manager.
Why do we need another I/O manager based on select? Why isn't the poll()
one good enough as a baseline portable unix I/O manager? Because macOS.
Apple Inc. is why we cannot have nice things.
The man page for poll on macOS documents the fact that it does not work.
At least, it does not work for all files. Specifically, it does not work
for device files. Whereas macOS select() does work for device files.
Aaaaarg!
We _do_ want to deprecate and remove the old select I/O manager, but due to
macOS we cannot do that until we have a replacement. This is that
replacement. Until of course a nice new k-queue I/O manager arrives,
which could become the new default for macOS and FreeBSD.
Interestingly, this select I/O manager is actually faster than the poll
one, on Linix, in some circumstances: specifically when many Haskell
threads are waiting on the same fd. The poll I/O manager does O(n) work
for n threads waiting on I/O, whereas the select one does O(fds) work
for the number of fds that threads are waiting on. Usually this is 1:1,
so it's not noticable, but one can concoct extreme benchmarks to show
the difference.
- - - - -
53ae2a48 by Duncan Coutts at 2026-07-17T15:04:59+01:00
Add the new select I/O manager to the user guide
in the RTS section about I/O managers.
And add a changelog entry.
- - - - -
e5766371 by Duncan Coutts at 2026-07-17T15:04:59+01:00
Update the "location" for blockedOnBadFD exception
This exception is thrown by the select, selectbis and poll I/O managers
in rare circumstances. The existing location for the error was
"awaitEvent" which is an old name that was internal to the RTS. The
Haskell functions which this gets thrown from are the functions
threadWaitRead / threadWaitWrite. So this is a more appropriate loction
string.
- - - - -
db1ba766 by Duncan Coutts at 2026-07-17T15:04:59+01:00
Minor updates in the poll I/O manager
to keep in sync with select one, based on code review when implementing
the new select I/O manager. The two are so similar that it makes sense
to try to minimise the diff between them.
- - - - -
ddaede06 by Duncan Coutts at 2026-07-17T15:06:15+01:00
Use selectbis I/O manager by default for CI coverage
This should not be committed to master.
It would be nice however to get better CI coverage of non-default I/O
managers.
- - - - -
17 changed files:
- + changelog.d/select-io-manager
- docs/users_guide/runtime_control.rst
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/configure.ac
- rts/include/rts/Flags.h
- rts/posix/Poll.c
- + rts/posix/SelectBis.c
- + rts/posix/SelectBis.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/rts.cabal
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
Changes:
=====================================
changelog.d/select-io-manager
=====================================
@@ -0,0 +1,19 @@
+section: rts
+issues:
+mrs: !16359
+synopsis:
+ New I/O manager based on select()
+description:
+ There is a new I/O manager on Posix systems based on select(). This exists
+ primarily to support macOS, where the poll() API does not work correctly
+ (specifically it is documented not to work for device files). It is the new
+ default I/O manager for the non-threaded RTS for the macOS platform.
+
+ This is intended to allow the legacy select I/O manager to be retired. It is
+ also a stop-gap measure until a kqueue I/O manager is added.
+
+ The new implementation is marginally faster in some cases. It scales better
+ for timers, O(log n) rather than O(m). For threads waiting on I/O it is
+ necessarily still O(n). If used to wait on fds > 1024 it will throw an IO
+ exception rather than terminating the RTS, as was the behaviour of the old
+ select I/O manager.
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -1441,15 +1441,30 @@ limited.
Currently the available I/O managers are:
================ ========= ============
- Name Platforms RTS way
+I/O manager name Platforms RTS way
================ ========= ============
``select`` Posix Non-threaded
-``poll`` Posix Non-threaded
+``selectbis`` Posix Non-threaded
+``poll`` Posix(*) Non-threaded
``mio`` All Threaded
``win32-legacy`` Windows Non-threaded
``winio`` Windows Both
================ ========= ============
+(*) The ``poll`` I/O manager is not available on macOS due to platform
+limitations.
+
+Currently the default I/O manager on each platform is:
+
+========= ============ ===================
+Platform RTS way default I/O manager
+========= ============ ===================
+macOS Non-threaded ``selectbis``
+Posix Non-threaded ``poll``
+Windows Non-threaded ``win32-legacy``
+all Threaded ``mio``
+========= ============ ===================
+
.. rts-flag:: --io-manager=(name)
Select the I/O manager to use. On some combinations of platform and
@@ -1474,7 +1489,8 @@ This is because it uses a linked list for timers.
This I/O manager is highly portable and its code is very mature: it is the I/O
manager that has been used by GHC in the single-threaded RTS on Posix platforms
-since time immemorial.
+since time immemorial. It is likely to be retired, once the ``poll`` and
+``selectbis`` I/O managers are mature enough to cover all use cases.
Timer resolution: on 64bit platforms it supports microsecond precision timers
while on 32bit platforms it only supports millisecond precision. Timer accuracy
@@ -1485,6 +1501,29 @@ support 1024 open files. More specifically it supports file descriptors with
numerical value up to 1024 but no higher. It will terminate the RTS (and thus
typically the process) if this limit is exceeded.
+The ``selectbis`` I/O manager
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This I/O manager based on the classic Posix ``select()`` API. It supports
+waiting on I/O readiness on non-blocking file descriptors (i.e. not disk files).
+It is implemented within the RTS and is currently available only in the
+non-threaded RTS.
+
+It scales poorly for I/O readiness notification: costing O(n) in the number of
+threads that are waiting on I/O simultaneously. It scales well for timers:
+most timer operations cost O(log n) in the number of simultaneous timers. This
+is because it uses a heap data structure for timers.
+
+Timer resolution: this I/O manager supports microsecond precision timers.
+
+Limitation: on most platforms where it is available this I/O manager can only
+support 1024 open files. More specifically it supports file descriptors with
+numerical value up to 1024 but no higher. It will throw an IO exception if this
+limit is exceeded.
+
+This I/O manager exists primarily to support macOS, due to ``poll()`` not
+working properly on macOS, while ``select()`` does work. It's name reflects
+the fact that it is the second I/O manager to be based on ``select()``.
+
The ``poll`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1512,6 +1551,10 @@ limit can be adjusted using OS facilities (e.g. the ``ulimit`` command).
Exceeding this limit will cause the RTS (and thus typically the process) to
terminate.
+This I/O manager is not available on macOS due to the ``poll()`` API not
+working for all file types on macOS. Specifically the macOS man page for
+``poll`` documents that it does not work for device files.
+
The ``mio`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~
This I/O manager is based on several platform-specific APIs. It supports
=====================================
libraries/base/src/GHC/RTS/Flags.hs
=====================================
@@ -390,10 +390,11 @@ internal_to_base_MiscFlags i@Internal.MiscFlags{..} =
internal_to_base_ioManager Internal.IoManagerFlagAuto = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagSelect = IoManagerFlagSelect
#if __GLASGOW_HASKELL__ >= 1000
+ internal_to_base_ioManager Internal.IoManagerFlagSelectBis = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagPoll = IoManagerFlagAuto
- -- This is a lie, we cannot translate poll. We cannot translate
- -- accurately because want to freeze the API of the the compat RTS flags
- -- here. Using "auto" is the least bad translation.
+ -- This is a lie, we cannot translate these new I/O managers. We cannot
+ -- translate accurately because want to freeze the API of the the compat
+ -- RTS flags here. Using "auto" is the least bad translation.
-- https://github.com/haskell/core-libraries-committee/issues/362
#endif
internal_to_base_ioManager Internal.IoManagerFlagMIO = IoManagerFlagMIO
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs
=====================================
@@ -188,7 +188,7 @@ threadWait evt fd = mask_ $ do
-- used at least by RTS in 'select()' IO manager backend
blockedOnBadFD :: SomeException
-blockedOnBadFD = toException $ errnoToIOError "awaitEvent" eBADF Nothing Nothing
+blockedOnBadFD = toException $ errnoToIOError "threadWaitRead/Write" eBADF Nothing Nothing
threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM evt fd = mask_ $ do
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
=====================================
@@ -184,6 +184,7 @@ data MiscFlags = MiscFlags
data IoManagerFlag =
IoManagerFlagAuto
| IoManagerFlagSelect -- ^ Unix only, non-threaded RTS only
+ | IoManagerFlagSelectBis -- ^ Unix only, non-threaded RTS only
| IoManagerFlagPoll -- ^ Unix only, non-threaded RTS only
| IoManagerFlagMIO -- ^ cross-platform, threaded RTS only
| IoManagerFlagWinIO -- ^ Windows only
=====================================
rts/IOManager.c
=====================================
@@ -33,6 +33,10 @@
#include "posix/Signals.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include "posix/SelectBis.h"
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
#include "posix/Poll.h"
#include "posix/Timeout.h"
@@ -117,6 +121,14 @@ parseIOManagerFlag(const char *iomgrstr, IO_MANAGER_FLAG *flag)
return IOManagerAvailable;
#else
return IOManagerUnavailable;
+#endif
+ }
+ else if (strcmp("selectbis", iomgrstr) == 0) {
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ *flag = IO_MNGR_FLAG_SELECTBIS;
+ return IOManagerAvailable;
+#else
+ return IOManagerUnavailable;
#endif
}
else if (strcmp("poll", iomgrstr) == 0) {
@@ -226,6 +238,8 @@ void selectIOManager(void)
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
iomgr_type = IO_MANAGER_SELECT;
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ iomgr_type = IO_MANAGER_SELECTBIS;
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
iomgr_type = IO_MANAGER_POLL;
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -244,6 +258,12 @@ void selectIOManager(void)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MNGR_FLAG_SELECTBIS:
+ iomgr_type = IO_MANAGER_SELECTBIS;
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MNGR_FLAG_POLL:
iomgr_type = IO_MANAGER_POLL;
@@ -291,6 +311,10 @@ char * showIOManager(void)
case IO_MANAGER_SELECT:
return "select";
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return "selectbis";
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return "poll";
@@ -347,6 +371,12 @@ void initCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ initCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
initCapabilityIOManagerPoll(iomgr);
@@ -380,6 +410,12 @@ void freeCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ freeCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
freeCapabilityIOManagerPoll(iomgr);
@@ -399,10 +435,14 @@ void startIOManager(void)
switch (iomgr_type) {
-#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#if defined(IOMGR_ENABLED_SELECT)
case IO_MANAGER_SELECT:
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
#endif
@@ -479,6 +519,7 @@ restartIOManager(CapIOManager *iomgr, Capability **pcap)
break;
#endif
/* The IO_MANAGER_SELECT needs no initialisation */
+ /* The IO_MANAGER_SELECTBIS needs no initialisation */
/* The IO_MANAGER_POLL needs no initialisation */
/* No impl for any of the Windows I/O managers, since no forking. */
@@ -570,8 +611,13 @@ void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
markClosureTable(evac, user, &iomgr->aiop_table);
evac(user, (StgClosure **)(void *)&iomgr->timeout_queue);
break;
@@ -599,8 +645,13 @@ void scavengeTSOIOManager(StgTSO *tso)
* both of these are not GC pointers, so there is nothing to do.
*/
+#if defined(IOMGR_ENABLED_SELECTBIS) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
/* BlockedOn{Read,Write} uses block_info.aiop
* BlockedOnDelay uses block_info.timeout
* both of these are heap allocated, so we can do the same in all
@@ -650,6 +701,11 @@ bool anyPendingTimeoutsOrIO(CapIOManager *iomgr)
|| (iomgr->sleeping_queue != END_TSO_QUEUE);
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return anyPendingTimeoutsOrIOSelectBis(iomgr);
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return anyPendingTimeoutsOrIOPoll(iomgr);
@@ -709,6 +765,12 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ pollCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
pollCompletedTimeoutsOrIOPoll(iomgr);
@@ -743,6 +805,12 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ completed = awaitCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
completed = awaitCompletedTimeoutsOrIOPoll(iomgr);
@@ -784,6 +852,12 @@ void interruptIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ interruptIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
interruptIOManagerPoll(iomgr);
@@ -831,9 +905,12 @@ bool syncIOWaitReady(CapIOManager *iomgr,
return true;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return syncIOWaitReadySelectBis(iomgr, tso, rw, fd);
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
- ASSERT(tso->why_blocked == NotBlocked);
return syncIOWaitReadyPoll(iomgr, tso, rw, fd);
#endif
default:
@@ -854,6 +931,11 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso)
tso);
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ syncIOCancelSelectBis(iomgr, tso);
+ break;
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
syncIOCancelPoll(iomgr, tso);
@@ -895,8 +977,13 @@ bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
return true;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
return syncDelayTimeout(iomgr, tso, us_delay);
#endif
#if defined(IOMGR_ENABLED_WIN32_LEGACY)
@@ -931,8 +1018,13 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso)
removeThreadFromQueue(iomgr->cap, &iomgr->sleeping_queue, tso);
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
syncDelayCancelTimeout(iomgr, tso);
break;
#endif
=====================================
rts/IOManager.h
=====================================
@@ -53,6 +53,9 @@ extern bool rts_IOManagerIsWin32Native;
#if defined(IOMGR_BUILD_SELECT) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_SELECT
#endif
+#if defined(IOMGR_BUILD_SELECTBIS) && !defined(THREADED_RTS)
+ #define IOMGR_ENABLED_SELECTBIS
+#endif
#if defined(IOMGR_BUILD_POLL) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_POLL
#endif
@@ -95,6 +98,8 @@ extern bool rts_IOManagerIsWin32Native;
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
#define IOMGR_DEFAULT_STR "select"
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ #define IOMGR_DEFAULT_STR "selectbis"
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
#define IOMGR_DEFAULT_STR "poll"
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -115,6 +120,11 @@ extern bool rts_IOManagerIsWin32Native;
#else
#define IOMGR_ENABLED_STR_SELECT ""
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ #define IOMGR_ENABLED_STR_SELECTBIS " selectbis"
+#else
+ #define IOMGR_ENABLED_STR_SELECTBIS ""
+#endif
#if defined(IOMGR_ENABLED_POLL)
#define IOMGR_ENABLED_STR_POLL " poll"
#else
@@ -137,6 +147,7 @@ extern bool rts_IOManagerIsWin32Native;
#endif
#define IOMGRS_ENABLED_STR \
IOMGR_ENABLED_STR_SELECT \
+ IOMGR_ENABLED_STR_SELECTBIS \
IOMGR_ENABLED_STR_POLL \
IOMGR_ENABLED_STR_MIO \
IOMGR_ENABLED_STR_WINIO \
@@ -150,6 +161,9 @@ typedef enum {
#if defined(IOMGR_ENABLED_SELECT)
IO_MANAGER_SELECT,
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ IO_MANAGER_SELECTBIS,
+#endif
#if defined(IOMGR_ENABLED_POLL)
IO_MANAGER_POLL,
#endif
=====================================
rts/IOManagerInternals.h
=====================================
@@ -14,12 +14,19 @@
#include "IOManager.h"
-#if defined(IOMGR_ENABLED_POLL)
-#include <poll.h> /* for struct pollfd */
+#if defined(IOMGR_ENABLED_SELECTBIS) || defined(IOMGR_ENABLED_POLL)
#include "ClosureTable.h"
#include "TimeoutQueue.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include <sys/select.h> /* for fd_set */
+#endif
+
+#if defined(IOMGR_ENABLED_POLL)
+#include <poll.h> /* for struct pollfd */
+#endif
+
#include "BeginPrivate.h"
/* The per-capability data structures belonging to the I/O manager.
@@ -46,19 +53,27 @@ struct _CapIOManager {
StgTSO *sleeping_queue;
#endif
-#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECT) \
+ || defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#if defined(HAVE_PREEMPTION)
/* FDs for waking up the I/O manager when it is blocked waiting */
int interrupt_fd_r, interrupt_fd_w;
#endif
#endif
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_POLL) || defined(IOMGR_ENABLED_SELECTBIS)
/* AIOP and timeout collections shared by several I/O manager impls */
ClosureTable aiop_table;
StgTimeoutQueue *timeout_queue;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ struct fd_table_entry { int fd; IOReadOrWrite rw; } *fd_table;
+ fd_set *rfds, *wfds;
+ int ncompletions_extra; /* extra completions for synchronous failures */
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
/* Auxiliary table with size and indexes matching the aiop_table. This is
* aliased to the tail of the full poll table, which has a head entry for
=====================================
rts/configure.ac
=====================================
@@ -368,6 +368,15 @@ GHC_IOMANAGER_ENABLE([select], [EnableIOManagerSelect], [IOMGR_BUILD_SELECT],
[AC_MSG_ERROR([sys/select.h required by select I/O manager])],[])
fi])
+GHC_IOMANAGER_ENABLE([selectbis], [EnableIOManagerSelectBis], [IOMGR_BUILD_SELECTBIS],
+ [if test "$HostOS" = "mingw32"; then
+ EnableIOManagerSelectBis=NO
+ else
+ AC_CHECK_HEADER([sys/select.h],
+ [EnableIOManagerSelectBis=YES],
+ [AC_MSG_ERROR([sys/select.h required by selectbis I/O manager])],[])
+ fi])
+
GHC_IOMANAGER_ENABLE([poll], [EnableIOManagerPoll], [IOMGR_BUILD_POLL],
[if test "$HostOS" = "mingw32"; then
EnableIOManagerPoll=NO
@@ -407,6 +416,7 @@ if test "$HostOS" = "mingw32"; then
else
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [select], [EnableIOManagerSelect])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [poll], [EnableIOManagerPoll])
+ GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [selectbis], [EnableIOManagerSelectBis])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerThreadedDefault], [mio], [EnableIOManagerMIO])
fi
GHC_IOMANAGER_DEFAULT_CHECK_NOT_EMPTY([IOManagerNonThreadedDefault],[non-threaded])
@@ -419,6 +429,9 @@ dnl Now define CPP vars for the default ones (threaded and non-threaded)
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[select], [IOMGR_DEFAULT_NON_THREADED_SELECT])
+GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
+ [selectbis], [IOMGR_DEFAULT_NON_THREADED_SELECTBIS])
+
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[poll], [IOMGR_DEFAULT_NON_THREADED_POLL])
=====================================
rts/include/rts/Flags.h
=====================================
@@ -258,6 +258,7 @@ typedef enum _IO_MANAGER_FLAG {
/* All other choices pick only the requested one, with no fallback. */
IO_MNGR_FLAG_SELECT, /* Unix only, non-threaded RTS only */
+ IO_MNGR_FLAG_SELECTBIS, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_POLL, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_MIO, /* cross-platform, threaded RTS only */
IO_MNGR_FLAG_WINIO, /* Windows only */
=====================================
rts/posix/Poll.c
=====================================
@@ -133,7 +133,7 @@ the aiop_table, but still allows the full_poll_table to have an extra entry.
/* Forward declarations */
static bool enlargeTables(CapIOManager *iomgr);
static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void removeFromTables(CapIOManager *iomgr, int i);
static void reportPollError(int res, nfds_t nfds) STG_NORETURN;
@@ -224,7 +224,8 @@ void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso)
StgAsyncIOOp *aiop = tso->block_info.aiop;
ASSERT(aiop->notify_type == NotifyTSO);
ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
- ioCancel(iomgr, aiop);
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
/* We cannot use the normal notifyIOCompletion here. We are in the context
* of throwTo, interrupting a thread blocked on IO via an async exception.
* We don't put the TSO back on the run queue or change the why_blocked
@@ -250,27 +251,13 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop)
*/
ASSERT(aiop->notify_type != NotifyTSO);
if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
- ioCancel(iomgr, aiop);
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
notifyIOCompletion(iomgr, aiop);
}
}
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop)
-{
- int ix = aiop->index;
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
- }
- aiop->outcome = IOOpOutcomeCancelled;
-}
-
-
bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr)
{
return !isEmptyTimeoutQueue(iomgr->timeout_queue)
@@ -284,11 +271,16 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
switch (aiop->notify_type) {
case NotifyTSO:
{
+ /* We should be guaranteed that the tso is still on the same
+ * cap because the tso was not on the run queue of any cap and
+ * so is not subject to thread migration.
+ */
+ StgTSO *tso = aiop->notify.tso;
+ ASSERT(tso->cap == iomgr->cap);
if (aiop->outcome == IOOpOutcomeFailed && aiop->error == EBADF) {
/* The fd is invalid: raise an IOError exception in the blocked
* thread. (See bug #4934 for what happens without this.)
*/
- StgTSO *tso = aiop->notify.tso;
debugTrace(DEBUG_iomanager,
"Raising exception in thread %" FMT_StgThreadID
" blocked on an invalid fd", tso->id);
@@ -296,11 +288,6 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
(StgClosure *)blockedOnBadFD_closure,
false, NULL);
} else {
- /* We should be guaranteed that the tso is still on the same
- * cap because the tso was not on the run queue of any cap and
- * so is not subject to thread migration.
- */
- StgTSO *tso = aiop->notify.tso;
tso->why_blocked = NotBlocked;
tso->_link = END_TSO_QUEUE;
pushOnRunQueue(iomgr->cap, tso);
@@ -375,19 +362,7 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
aiop->result = 0;
}
- /* Remove from the completion table, preserving compactness, and
- * apply the same compacting to the aiop_poll_table.
- */
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, i,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to;
- aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- aiop_poll_table[ix_to] = aiop_poll_table[ix_from];
- }
-
+ removeFromTables(iomgr, i);
notifyIOCompletion(iomgr, aiop);
n--;
} else {
@@ -458,6 +433,10 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
reportPollError(res, nfds);
}
}
+
+#if defined(RTS_USER_SIGNALS)
+ startPendingSignalHandlers(iomgr->cap);
+#endif
}
@@ -546,14 +525,13 @@ bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
// on and so we sould check for timeouts.
} else if (errno == EINTR) {
- /* We got interrupted by a signal. In the non-threaded RTS, if the
- * signal is one of ours we need to return to the scheduler to let
- * it handle it. Otherwise we would loop and keep waiting for I/O
- * or timeouts, meaning we would block for a long time before the
- * signal is serviced.
- */
+ /* We got interrupted by a signal. */
+
#if defined(RTS_USER_SIGNALS)
- if (startPendingSignalHandlers(iomgr->cap)) break;
+ /* Start any corresponding user signal handlers. If any, the run
+ * queue will become non-empty and we will drop out of the loop.
+ */
+ startPendingSignalHandlers(iomgr->cap);
#endif
/* We can also be interrupted by the shutdown signal handler, which
@@ -628,4 +606,20 @@ static bool enlargeTables(CapIOManager *iomgr)
return true;
}
+
+/* Remove from the completion table, preserving compactness, and apply the same
+ * compacting to the aiop_poll_table.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
+ }
+}
+
#endif /* IOMGR_ENABLED_POLL */
=====================================
rts/posix/SelectBis.c
=====================================
@@ -0,0 +1,716 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * See SelectBis.h for the sad story of why this exists.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "rts/PosixSource.h"
+#include "Rts.h"
+#include "RtsFlags.h" // needed by SET_HDR macro
+
+#include "IOManager.h" // defines IOMGR_ENABLED_SELECTBIS
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+#include "Capability.h"
+#include "Threads.h"
+#include "Schedule.h"
+#include "Prelude.h"
+#include "RtsUtils.h"
+#include "rts/Time.h"
+#include "RaiseAsync.h"
+#include "Trace.h"
+
+#include "SelectBis.h"
+#include "RtsSignals.h"
+
+#include <sys/select.h>
+#include <errno.h>
+
+#include "IOManagerInternals.h"
+#include "Timeout.h"
+#include "FdWakeup.h"
+
+/******************************************************************************
+
+This I/O manager is based on the classic Unix select() system call.
+
+ int select(int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, struct timeval *timeout);
+
+The select() call has various limits, quirks and slight differences between
+historical Unix variants.
+
+The basic idea is to collect a set of fds (represented as a bitset) that we are
+interested in: one for reads, one for writes. The call then queries for I/O
+readiness on all the fds in the read and write sets. The result is a set of fds
+that are ready to read from, and a set that are ready to write to. The same
+bitset representation is used for the output. Indeed a "fun" quirk of select()
+is that it mutates the fd sets it is passed, which means they either need to be
+built up each time, or copied. There is also an optional timeout if no fds are
+ready immediately. There is also an fd bitset for "exceptional conditions"
+which we do not use.
+
+There is of course no incremental behaviour here; this is a bulk one-off call
+with no persistent state. This has obvious scaling problems. The cost each time
+is O(n) in the maximum of the integer value of the fds of interest. There is
+also a maximum bitset size. On Linux this is 1024. This means select() cannot
+be used if the process uses more than that many open files, even if we're only
+interested in a few. On OSX the default limit is also 1024 but this can be
+raised or even managed dynamically, at the cost of more memory (and some
+non-standard code).
+
+That particular problem is solved by the later Unix poll() system call, which
+uses an array of the fds we are interested in, which means it not limited by
+the absolute value of the fds numbers (but it is still O(n) in how many fds we
+are interested in).
+
+We have some choice in how we process results. We want to find the intersection
+between the requests for notification of I/O readiness (coming from the Haskell
+threads) and the read and write bit sets. There's not much clever we can do to
+compute this intersection efficiently: we can either iterate over the bit sets
+or over the readiness requests. There is no obvious answer here. Typically
+there will be few results compared to the number of requests and a bitset scan
+could be fast. In practice we cannot portably scan the bitset efficiently (e.g.
+word at a time). Portably, we can only probe each bit at a time using FD_ISSET.
+Portability is the main reason to use select() rather than a more modern
+interface, so we have to take it seriously here. Furthermore, if we iterated
+over the bit sets we would have to maintain a mapping from fd to requests.
+
+In principle we also have the choice to maintain the read and write fd bit sets
+incrementally, or create them afresh each time we call select(). There is no
+asymptotic bonus to maintaining them incrementally since the whole thing is
+O(n) anyway. There could plausibly be some constant factor benefit. To maintain
+the fd bit sets incrementally we would need to maintain a mapping between
+requests and fds. This would also be an extra cost that would have to be
+outweighed by any saving.
+
+In the end we take the simple approach to constructing the bitset inputs and to
+results processing. We create the bit sets afresh each time from the collection
+of requests. For processing results we iterate over the requests and look up
+each one to see if it is in the appropriate result bitset. Along with each
+operation, we store the fd and whether we were interested in reading or writing.
+We iterate over the operations and use the fd and r/w information to construct
+the read and write bit sets.
+
+A particularly frustrating feature of select() is that if any single fd in any
+fd bitset is invalid (e.g. because the file was already closed) then select()
+fails and tells us there is a bad fd somewhere, but it has no way to indicate
+which fd was bad. This is really quite annoying as we then have to do a search
+through the fds to find which one was bad.
+
+The primary data structure for this I/O manager is a aiop_table which is a
+ClosureTable of AsyncIOOps. This table tracks the active I/O operations, with
+one entry per operation (corresponding to threads calling waitRead#/waitWrite#).
+We also track the fd for each operation and whether the operation is waiting on
+read or write readiness. This additional information is stored in the fd_table.
+The fd_table is maintained as an auxiliary table to the aiop_table, with table
+indexes matching the ClosureTable. So there is an entry in the aiop_table for
+each operation, and a corresponding entry in the fd_table at the same table
+index. The aiop_table and the fd_table are maintained incrementally, and with
+dense indexes.
+
+We also use a StgTimeoutQueue to track timeouts, and use the delay to the next
+timeout (if any) as the poll() timeout parameter.
+
+The CapIOManager structure for this I/O manager contains:
+
+ ClosureTable aiop_table;
+ struct fd_table_entry { int fd; IOReadOrWrite rw } *fd_table;
+ StgTimeoutQueue *timeout_queue;
+ int interrupt_fd_r, interrupt_fd_w;
+
+******************************************************************************/
+
+/* Forward declarations */
+static bool enlargeTables(CapIOManager *iomgr);
+static void removeFromTables(CapIOManager *iomgr, int i);
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void reportSelectError(void) STG_NORETURN;
+static bool checkFdRange(int fd);
+static int collectFdSets(CapIOManager *iomgr);
+static void processBadFds(CapIOManager *iomgr);
+
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ initClosureTable(&iomgr->aiop_table, ClosureTableCompact);
+ iomgr->timeout_queue = emptyTimeoutQueue();
+
+#if defined(HAVE_PREEMPTION)
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+
+ /* Would never happen in a standalone process, but could plausibly happen
+ * if the RTS is used within another process that already has many open fds.
+ */
+ if (iomgr->interrupt_fd_r < 0 || iomgr->interrupt_fd_r >= (int)FD_SETSIZE ||
+ iomgr->interrupt_fd_w < 0 || iomgr->interrupt_fd_w >= (int)FD_SETSIZE) {
+ barf("initCapabilityIOManagerSelectBis: fds out of select range");
+ }
+#endif
+
+ iomgr->fd_table = NULL;
+ iomgr->rfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+ iomgr->wfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+ iomgr->ncompletions_extra = 0;
+}
+
+
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ if (iomgr->fd_table) stgFree(iomgr->fd_table);
+ stgFree(iomgr->rfds);
+ stgFree(iomgr->wfds);
+#if defined(HAVE_PREEMPTION)
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Result is true on success, or false on allocation failure. */
+bool syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ IOReadOrWrite rw, HsInt fd)
+{
+ StgAsyncIOOp *aiop;
+ aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
+ if (RTS_UNLIKELY(aiop == NULL)) return false;
+ SET_HDR(aiop, &stg_ASYNCIOOP_info, iomgr->cap->r.rCCCS);
+ aiop->notify.tso = tso;
+ aiop->notify_type = NotifyTSO;
+ aiop->live = &stg_ASYNCIO_LIVE0_closure;
+ tso->why_blocked = rw == IORead ? BlockedOnRead : BlockedOnWrite;
+ tso->block_info.aiop = aiop;
+ return asyncIOWaitReadySelectBis(iomgr, aiop, rw, fd);
+}
+
+/* Result is true on success, or false on allocation failure. */
+bool asyncIOWaitReadySelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop,
+ IOReadOrWrite rw, int fd)
+{
+ if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
+ bool ok = enlargeTables(iomgr);
+ if (RTS_UNLIKELY(!ok)) return false;
+ }
+
+ int ix = insertClosureTable(iomgr->cap, &iomgr->aiop_table, aiop);
+
+ /* We use the aiop_table and fd_table densely. */
+ ASSERT(ix == sizeClosureTable(&iomgr->aiop_table) - 1);
+
+ /* The syncIO wrapper or CMM primop filled in the notify and live fields,
+ * we fill the rest.
+ */
+ aiop->capno = iomgr->cap->no;
+ aiop->index = ix;
+ aiop->outcome = IOOpOutcomeInFlight;
+
+ /* Fill in the corresponding entry in the fd_table */
+ iomgr->fd_table[ix] = (struct fd_table_entry) {
+ .fd = fd,
+ .rw = rw
+ };
+
+ if (!checkFdRange(fd)) {
+ /* We have a synchronous failure, but the primop is not set up to report
+ * exceptions. We cannot report async exceptions to the caller here
+ * since the thread stack is not in the right state (so we cannot use
+ * notifyIOCompletion). So instead we mark the aiop as failed now, but
+ * we report the failure later when we poll for completed I/O.
+ */
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ /* completions for synchronous failures to report asynchronously */
+ iomgr->ncompletions_extra++;
+ };
+
+ return true;
+}
+
+
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso)
+{
+ StgAsyncIOOp *aiop = tso->block_info.aiop;
+ ASSERT(aiop->notify_type == NotifyTSO);
+ ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
+ /* We cannot use the normal notifyIOCompletion here. We are in the context
+ * of throwTo, interrupting a thread blocked on IO via an async exception.
+ * We don't put the TSO back on the run queue or change the why_blocked
+ * status, as that is done by removeFromQueues (in the throwTo* functions).
+ */
+ tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
+
+ /* We are in the TSO case, where the aiop was only reachable from the TSO
+ * itself, and thus it is now no longer be reachable at all.
+ */
+ IF_NONMOVING_WRITE_BARRIER_ENABLED {
+ updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
+ }
+}
+
+
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ /* We can reliably determine if the aiop is still in progress by checking
+ * if the aiop_table still points to this aiop object. This is reliable
+ * because each aiop is GC heap allocated, so cannot be recycled until it
+ * is no longer retained by the application.
+ */
+ ASSERT(aiop->notify_type != NotifyTSO);
+ if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
+ notifyIOCompletion(iomgr, aiop);
+ }
+}
+
+
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ return !isEmptyTimeoutQueue(iomgr->timeout_queue)
+ || !isEmptyClosureTable(&iomgr->aiop_table);
+}
+
+
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ ASSERT(aiop->outcome != IOOpOutcomeInFlight);
+ switch (aiop->notify_type) {
+ case NotifyTSO:
+ {
+ /* We should be guaranteed that the tso is still on the same
+ * cap because the tso was not on the run queue of any cap and
+ * so is not subject to thread migration.
+ */
+ StgTSO *tso = aiop->notify.tso;
+ ASSERT(tso->cap == iomgr->cap);
+ if (aiop->outcome == IOOpOutcomeFailed && aiop->error == EBADF) {
+ /* The fd is invalid: raise an IOError exception in the blocked
+ * thread. (See bug #4934 for what happens without this.)
+ */
+ debugTrace(DEBUG_iomanager,
+ "Raising exception in thread %" FMT_StgThreadID
+ " blocked on an invalid fd", tso->id);
+ raiseAsync(iomgr->cap, tso,
+ (StgClosure *)blockedOnBadFD_closure,
+ false, NULL);
+ } else {
+ tso->why_blocked = NotBlocked;
+ tso->_link = END_TSO_QUEUE;
+ pushOnRunQueue(iomgr->cap, tso);
+ }
+ /* For the TSO case, the aiop was only reachable from the TSO
+ * itself, and thus it is now no longer be reachable at all.
+ */
+ IF_NONMOVING_WRITE_BARRIER_ENABLED {
+ updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
+ }
+ break;
+ }
+ case NotifyMVar:
+ barf("selectbis iomgr: MVar notification not yet supported");
+ break;
+
+ case NotifyTVar:
+ barf("selectbis iomgr: TVar notification not yet supported");
+ break;
+ }
+}
+
+
+static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
+{
+ /* We want to find the intersection between the sets of ready fds returned
+ * by select() and the aiop_table. Given how select() represents
+ * things there's no particularly efficient way to do it.
+ *
+ * We just go through the whole aiop_table and look up each one in
+ * the read or write fd_set to see if they completed. Note that here is
+ * where we rely on the aiop_table being dense so we can iterate
+ * over the entries. We can short-cut if we hit the ncompletions before
+ * getting to the end of the table.
+ */
+ debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
+ ncompletions);
+
+ bool interrupt = false;
+#if defined(HAVE_PREEMPTION)
+ /* If the interrupt_fd_r is ready, collect it */
+ if (FD_ISSET(iomgr->interrupt_fd_r, iomgr->rfds)) {
+ ASSERT(iomgr->full_poll_table[0].fd == iomgr->interrupt_fd_r);
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ ncompletions--;
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager");
+ }
+#endif
+
+ struct fd_table_entry *fd_table = iomgr->fd_table;
+ int n = ncompletions;
+ int i = 0;
+ while (n > 0) {
+ ASSERT(i < sizeClosureTable(&iomgr->aiop_table));
+
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ int fd = fd_table[i].fd;
+ IOReadOrWrite rw = fd_table[i].rw;
+
+ if (RTS_UNLIKELY(aiop->outcome == IOOpOutcomeFailed)) {
+ /* The synchronous failure case, see ncompletions_extra. */
+ } else if (rw == IORead ? FD_ISSET(fd, iomgr->rfds)
+ : FD_ISSET(fd, iomgr->wfds)) {
+ aiop->outcome = IOOpOutcomeSuccess;
+ aiop->result = 0;
+ } else {
+ /* You'd expect incrementing the table index to be unconditional,
+ * but we don't increment the index if we did process the entry,
+ * because using removeFromTables means we'll move an entry from
+ * the end of the table into the index i.
+ */
+ i++;
+ continue; /* skip the steps below */
+ }
+ removeFromTables(iomgr, i);
+ notifyIOCompletion(iomgr, aiop);
+ n--;
+ }
+ return interrupt;
+}
+
+
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+ }
+
+ if (!isEmptyClosureTable(&iomgr->aiop_table)) {
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Poll for I/O readiness, without waiting. */
+ struct timeval tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, &tv);
+ if (res == 0 && iomgr->ncompletions_extra == 0) {
+ /* There is no I/O ready. We'll return to the scheduler. */
+
+ } else if (res > 0 || iomgr->ncompletions_extra > 0) {
+ /* Extra completions for synchronous failures to report */
+ int ncompletions = res + iomgr->ncompletions_extra;
+ iomgr->ncompletions_extra = 0;
+
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table));
+ processIOCompletions(iomgr, ncompletions);
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. This is unlikely since we asked
+ * select() not to wait, but if so we'll return to the scheduler.
+ */
+
+ } else {
+ reportSelectError();
+ }
+ }
+
+#if defined(RTS_USER_SIGNALS)
+ startPendingSignalHandlers(iomgr->cap);
+#endif
+}
+
+
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ bool interrupt = false; /* got woken up via interruptIOManager */
+
+ /* Loop until we've woken up some threads. This loop is needed because the
+ * select() timing isn't accurate, we sometimes sleep for a while but not
+ * long enough to wake up a thread in a threadDelay. Or we may need to
+ * sleep multiple times if we need to sleep longer than the maximum timeout
+ * that select() supports.
+ */
+ do {
+ /* We do /not/ require that there be pending I/O or pending timers.
+ * If there is neither, it's because the scheduler wants us to wait
+ * on signals only.
+ */
+
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+
+ /* If we didn't wake any threads due to expiring timeouts, then we need
+ * to wait on I/O. Or to put it another way, even if we did wake some
+ * threads, we'll still poll (but not wait) for I/O. This is to ensure
+ * we avoid starving threads blocked on I/O.
+ */
+ bool wait = emptyRunQueue(iomgr->cap);
+
+ /* If we have failures to report, we must not block. */
+ if (iomgr->ncompletions_extra > 0) {
+ wait = false;
+ }
+
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Decide if we are going to wait if no I/O is ready, either:
+ * poll only, wait indefinitely, or wait until a timeout.
+ */
+ struct timeval tv, *timeout_us;
+ timeout_us = timeoutInMicroseconds(iomgr, wait, now, &tv);
+
+ /* Check for I/O readiness, possibly waiting. */
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, timeout_us);
+
+ if (res == 0 && iomgr->ncompletions_extra == 0) {
+ /* Success but there is no I/O ready. This can happen either if we
+ * were not blocking or were in a timed wait and the timeout
+ * occurred before any I/O became ready. Either way, the do-while
+ * loop condition will handle it.
+ */
+ ASSERT(timeout_us != NULL);
+
+ } else if (res > 0 || iomgr->ncompletions_extra > 0) {
+ /* Extra completions for synchronous failures to report */
+ int ncompletions = res + iomgr->ncompletions_extra;
+ iomgr->ncompletions_extra = 0;
+
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table));
+ interrupt = processIOCompletions(iomgr, ncompletions);
+ // FIXME: do we also need to check for timeout completions now?
+ // we have a non-empty queue, but if !wait then we have also moved
+ // on and so we sould check for timeouts.
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. */
+
+#if defined(RTS_USER_SIGNALS)
+ /* Start any corresponding user signal handlers. If any, the run
+ * queue will become non-empty and we will drop out of the loop.
+ */
+ startPendingSignalHandlers(iomgr->cap);
+#endif
+
+ /* We can also be interrupted by the shutdown signal handler, which
+ * will set sched_state and so cause us to drop out of the loop.
+ *
+ * For any other interruption (e.g. timer) we will go round the
+ * do-while loop again.
+ */
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else {
+ reportSelectError();
+ }
+
+ } while (emptyRunQueue(iomgr->cap)
+ && !interrupt
+ && (getSchedState() == SCHED_RUNNING));
+ return !interrupt;
+}
+
+
+static void reportSelectError()
+{
+ sysErrorBelch("select() failed");
+ stg_exit(EXIT_FAILURE);
+}
+
+
+static void processBadFds(CapIOManager *iomgr)
+{
+ /* This is extremely tiresome. The select() call fails with EBADF if any
+ * fd is invalid (usually closed), but it does not tell us which one.
+ * So we have to loop through them to find the offending fd.
+ *
+ * This will only find the first bad fd, so the caller must cope with
+ * there still being bad fds after this.
+ */
+
+ fd_set rfds, wfds;
+ FD_ZERO(&rfds);
+ FD_ZERO(&wfds);
+
+ struct fd_table_entry *fd_table = iomgr->fd_table;
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+ for (int n = 0; n < nentries; n++) {
+ int fd = fd_table[n].fd;
+ IOReadOrWrite rw = fd_table[n].rw;
+
+ struct timeval tv = { .tv_sec = 0, .tv_usec = 0 };
+ int res;
+ if (rw == IORead) {
+ FD_SET(fd, &rfds);
+ res = select(fd+1, &rfds, NULL, NULL, &tv);
+ FD_CLR(fd, &rfds);
+ } else {
+ FD_SET(fd, &wfds);
+ res = select(fd+1, NULL, &wfds, NULL, &tv);
+ FD_CLR(fd, &wfds);
+ }
+ if (res == 0) {
+ continue;
+
+ } else if (errno == EBADF) {
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, n);
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ removeFromTables(iomgr, n);
+ notifyIOCompletion(iomgr, aiop);
+ /* There is /probably/ only one bad fd at once, so we abort the
+ * search here. If we are unlucky and there are several bad fds
+ * then the caller will just loop round again.
+ */
+
+ return;
+
+ } else if (errno == EINTR) {
+ /* Unlikely, since we did a non-blocking select(). Try again. */
+ n--;
+ continue;
+
+ } else {
+ reportSelectError();
+ }
+ }
+}
+
+
+void interruptIOManagerSelectBis(CapIOManager *iomgr)
+{
+#if defined(HAVE_PREEMPTION)
+ sendFdWakeup(iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Helper function to double the size of the aiop_table and fd_table.
+ */
+static bool enlargeTables(CapIOManager *iomgr)
+{
+ int oldcapacity = capacityClosureTable(&iomgr->aiop_table);
+ int newcapacity = (oldcapacity == 0) ? 1 : (oldcapacity * 2);
+
+ bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity);
+ if (RTS_UNLIKELY(!ok)) return false;
+
+ /* Update the auxiliary fd_table to match */
+ iomgr->fd_table =
+ stgReallocBytes(iomgr->fd_table,
+ sizeof(struct fd_table_entry) * newcapacity,
+ "SelectBis.c: enlargeTables");
+
+ /* Initialise the new part of the fd_table */
+ struct fd_table_entry *fd_table = iomgr->fd_table;
+ for (int i = oldcapacity; i < newcapacity; i++) {
+ fd_table[i] = (struct fd_table_entry) {
+ .fd = -1,
+ .rw = 0
+ };
+ }
+ return true;
+}
+
+
+/* Remove from the completion table, preserving compactness, and apply the same
+ * compacting to the fd_table.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ iomgr->fd_table[ix_to] = iomgr->fd_table[ix_from];
+ iomgr->fd_table[ix_from] = (struct fd_table_entry) {
+ .fd = -1,
+ .rw = 0
+ };
+ }
+}
+
+
+static int collectFdSets(CapIOManager *iomgr)
+{
+ int maxfd = -1;
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+ struct fd_table_entry *fd_table = iomgr->fd_table;
+
+ /* In principle we could optimise this slightly by not resetting the
+ * whole of each fdset, by assuming that select() does not modify
+ * entries above maxfd. This is probably not worth doing however, since
+ * this I/O manager is supposed to be portable and is expected to be slow.
+ */
+ FD_ZERO(iomgr->rfds);
+ FD_ZERO(iomgr->wfds);
+
+#if defined(HAVE_PREEMPTION)
+ /* We're always interested in our interrupt fd */
+ {
+ int fd = iomgr->interrupt_fd_r;
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ FD_SET(fd, iomgr->rfds);
+ }
+#endif
+
+ for (int i = 0; i < nentries; i++) {
+ int fd = fd_table[i].fd;
+ IOReadOrWrite rw = fd_table[i].rw;
+ ASSERT(fd != -1); // uninitialised
+
+ // Skip aiops that we already know are failed
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ if (RTS_UNLIKELY(aiop->outcome == IOOpOutcomeFailed)) continue;
+
+ if (rw == IORead) {
+ FD_SET(fd, iomgr->rfds);
+ } else {
+ FD_SET(fd, iomgr->wfds);
+ }
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ }
+ return maxfd;
+}
+
+
+/* Helper function to check if the fd is out of range for select().
+ */
+static bool checkFdRange(int fd)
+{
+ /* On older FreeBSDs, FD_SETSIZE is unsigned. Cast it to signed int
+ * in order to switch off the 'comparison between signed and
+ * unsigned error message
+ * Newer versions of FreeBSD have switched to unsigned int:
+ * https://github.com/freebsd/freebsd/commit/12ae7f74a071f0439763986026525094a…
+ * http://fa.freebsd.cvs-all.narkive.com/bCWNHbaC/svn-commit-r265051-head-sys-…
+ * So the (int) cast should be removed across the code base once
+ * GHC requires a version of FreeBSD that has that change in it.
+ */
+ return ((fd >= 0) && (fd < (int)FD_SETSIZE));
+ /* TODO: on several platforms, it is possible to use a larger fd set size.
+ For example on OSX:
+ https://code.saghul.net/2016/05/libuv-internals-the-osx-select2-trick/
+ And probably similar on other platforms. It basically amounts to looking
+ through the representation abstraction of fd_set and to know that it is
+ indeed a bit set, and then we can simply allocate it and manipulte it
+ ourselves. We could do this, dynamically (re-)allocate the size.
+ */
+}
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
=====================================
rts/posix/SelectBis.h
=====================================
@@ -0,0 +1,61 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * This I/O manager is called "selectbis", because it is the second such I/O
+ * manager based on select(). The historic implementation is named "select"
+ * and lives in Select.{c,h}. This I/O manager exists for the benefit of users
+ * of Apple products.
+ *
+ * The poll I/O manger _should_ be the portable baseline posix I/O manager.
+ * Unfortunately Mac OSX has a buggy implementation of poll(). The OSX man
+ * page documents this as:
+ *
+ * > BUGS The poll() system call currently does not support devices.
+ *
+ * This is quite incredible, given that poll and select should be relatively
+ * thin interfaces to the the same underlying kernel infrastructure.
+ * Furthermore, OSX is supposedly certified as POSIX compliant! Due to this
+ * (incompetence) we need a new I/O manager implementation based on the
+ * antique select() API, with all of its known limitations.
+ *
+ * Please direct all complaints to:
+ * Apple Inc., One Apple Park Way, Cupertino, CA 95014, USA.
+ *
+ * Prototypes for functions in SelectBis.c
+ *
+ * -------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "IOManager.h"
+
+#include "BeginPrivate.h"
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+
+/* Synchronous I/O and timer operations */
+bool syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ IOReadOrWrite rw, HsInt fd);
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso);
+
+/* Asynchronous operations */
+bool asyncIOWaitReadySelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop,
+ IOReadOrWrite rw, int fd);
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+
+/* Scheduler operations */
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void interruptIOManagerSelectBis(CapIOManager *iomgr);
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
+
+#include "EndPrivate.h"
+
=====================================
rts/posix/Timeout.c
=====================================
@@ -14,8 +14,9 @@
#include "Schedule.h"
#include "Prelude.h"
-#include "Timeout.h"
+#include "IOManager.h"
#include "IOManagerInternals.h"
+#include "Timeout.h"
#include "TimeoutQueue.h"
#include <limits.h>
@@ -24,7 +25,7 @@
/* Currently only used by the poll I/O manager, but in future may be used by
several in-RTS I/O managers.
*/
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_POLL) || defined(IOMGR_ENABLED_SELECTBIS)
bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
{
@@ -223,5 +224,58 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
}
#endif
-#endif // defined(IOMGR_ENABLED_POLL)
+/* select() expect a timeout in microseconds, using struct timeval * with
+ * special values of NULL for indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv)
+{
+ if (!wait) {
+ /* Don't wait, just poll. */
+ *tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ return tv;
+
+ } else if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ /* SUSv2 allows implementations to have an implementation defined
+ * maximum timeout for select(2). The standard requires
+ * implementations to silently truncate values exceeding this maximum
+ * to the maximum. Unfortunately, OSX and the BSD don't comply with
+ * SUSv2, instead opting to return EINVAL for values exceeding a
+ * timeout of 1e8.
+ *
+ * Select returning an error crashes the runtime in a bad way. To
+ * play it safe we truncate any timeout to 31 days, as SUSv2 requires
+ * any implementations maximum timeout to be larger than this.
+ *
+ * Truncating the timeout is not an issue, because if nothing
+ * interesting happens when the timeout expires, we'll see that the
+ * thread still wants to be blocked longer and simply block on a new
+ * iteration of select(2).
+ */
+ const time_t max_seconds = 2678400; // 31 * 24 * 60 * 60
+
+ Time waketime = findMinWaketimeTimeoutQueue(iomgr->timeout_queue);
+ Time waittime = waketime - now;
+
+ /* Any expired timeouts should have been cleared, so we must be waiting
+ * for a timeout in the future. */
+ ASSERT(waittime > 0);
+
+ tv->tv_sec = TimeToSeconds(waittime);
+ if (tv->tv_sec < max_seconds) {
+ tv->tv_usec = TimeToUS(waittime) % 1000000;
+ } else {
+ tv->tv_sec = max_seconds;
+ tv->tv_usec = 0;
+ }
+ return tv;
+
+ } else {
+ return NULL;
+ }
+}
+#endif
+
+#endif // defined(IOMGR_ENABLED_POLL) || defined(IOMGR_ENABLED_SELECTBIS)
=====================================
rts/posix/Timeout.h
=====================================
@@ -46,5 +46,15 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
Time now, struct timespec *tv);
#endif
+/* As above, but a timeout in microseconds. This is intended to be used with
+ * select() which expect struct timespec *, with special values of NULL for
+ * indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv);
+
+#endif
+
#include "EndPrivate.h"
=====================================
rts/rts.cabal
=====================================
@@ -571,6 +571,7 @@ library
wasm/JSFFI.c
wasm/JSFFIGlobals.c
posix/Select.c
+ posix/SelectBis.c
posix/Poll.c
posix/Timeout.c
cmm-sources: wasm/jsval.cmm
@@ -586,6 +587,7 @@ library
posix/MIO.c
posix/Poll.c
posix/Select.c
+ posix/SelectBis.c
posix/Signals.c
posix/Timeout.c
posix/TTY.c
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -7854,7 +7854,7 @@ module GHC.RTS.Flags.Experimental where
type HpcFlags :: *
data HpcFlags = HpcFlags {readTixFile :: GHC.Internal.Types.Bool, writeTixFile :: GHC.Internal.Types.Bool}
type IoManagerFlag :: *
- data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
+ data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagSelectBis | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a31182d9f52f006838501fde99f62e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a31182d9f52f006838501fde99f62e…
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/fendor/external-unit-db-cache] 6 commits: Add regression test for #26423
by Hannes Siebenhandl (＠fendor) 17 Jul '26
by Hannes Siebenhandl (＠fendor) 17 Jul '26
17 Jul '26
Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC
Commits:
c4d3db1f by fendor at 2026-07-17T15:13:43+02:00
Add regression test for #26423
- - - - -
5836db8d by fendor at 2026-07-17T15:13:43+02:00
WIP: introduce external unit database cache
- - - - -
cf0a8299 by fendor at 2026-07-17T15:13:43+02:00
Never modify UnitInfo for better sharing
- - - - -
01299d73 by fendor at 2026-07-17T15:13:43+02:00
WIP: Introduce UnitIndex for global data
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
mhu-perf
-------------------------
- - - - -
5d1666f3 by fendor at 2026-07-17T15:13:43+02:00
Split State.hs into many more modules
- - - - -
de821184 by fendor at 2026-07-17T15:13:43+02:00
Add memory usage regression test for UnitInfo
- - - - -
43 changed files:
- + changelog.d/unit-index
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Main/Interactive.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Unit/Env.hs
- + compiler/GHC/Unit/External/Database.hs
- + compiler/GHC/Unit/External/Index.hs
- + compiler/GHC/Unit/External/ModuleOrigin.hs
- + compiler/GHC/Unit/External/Providers.hs
- + compiler/GHC/Unit/External/Query.hs
- + compiler/GHC/Unit/External/Substitution.hs
- + compiler/GHC/Unit/External/Validate.hs
- + compiler/GHC/Unit/External/Visibility.hs
- + compiler/GHC/Unit/External/Wired.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- hadrian/src/Rules/Generate.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/driver/T26423/Hello.hs
- + testsuite/tests/driver/T26423/Makefile
- + testsuite/tests/driver/T26423/T26423.hs
- + testsuite/tests/driver/T26423/T26423.stderr
- + testsuite/tests/driver/T26423/T26423.stdout
- + testsuite/tests/driver/T26423/all.T
- + testsuite/tests/driver/T26423/test/Test.hs
- + testsuite/tests/driver/T26423/test/test.pkg
- + testsuite/tests/driver/TUnitInfo/Foo.hs
- + testsuite/tests/driver/TUnitInfo/Makefile
- + testsuite/tests/driver/TUnitInfo/all.T
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.stdout
- utils/haddock/haddock-api/src/Haddock.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba143db3fc92bcc1abcbde08d427fc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba143db3fc92bcc1abcbde08d427fc…
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] arm64 ncg: Fix subword handling of ffi calls.
by Andreas Klebinger (＠AndreasK) 17 Jul '26
by Andreas Klebinger (＠AndreasK) 17 Jul '26
17 Jul '26
Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
36f76098 by Andreas Klebinger at 2026-07-17T13:02:30+02:00
arm64 ncg: Fix subword handling of ffi calls.
Our invariants require us to clear the high bits for subword results.
We now do so both for unspecified bit casts (MO_CONV_XX) and when
taking in results from ffi calls.
I also renamed truncateReg to make it clear it changes the register.
- - - - -
4 changed files:
- + changelog.d/T27430
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- testsuite/tests/codeGen/should_run/T27430.hs
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
changelog.d/T27430
=====================================
@@ -0,0 +1,11 @@
+section: compiler
+issues: #27430
+mrs: !16255
+synopsis:
+ AArch64 code generation: Fix handling of subword return values at FFI boundary.
+description:
+ When calling C functions returning subword values, sometimes those values high
+ bit would incorrectly influence certain operations.
+
+ We now zero the high bits consistently to avoid this.
+
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -358,19 +358,13 @@ data Register
= Fixed Format Reg InstrBlock
| Any Format (Reg -> InstrBlock)
--- | Sometimes we need to change the Format of a register. Primarily during
--- conversion.
-swizzleRegisterRep :: Format -> Register -> Register
-swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code
-swizzleRegisterRep format (Any _ codefn) = Any format codefn
-
-- | Grab the Reg for a CmmReg
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg _ (CmmLocal (LocalReg u pk))
= RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
-getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _))
+getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _ty))
= case globalRegMaybe platform mid of
Just reg -> RegReal reg
Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)
@@ -662,7 +656,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
-- in between operations.
--
-- IMPORTANT: this invariant only holds within a single expression tree as
--- generated by the NCG (via truncateReg after each sub-word operation). It
+-- generated by the NCG (via truncateRegInplace after each sub-word operation). It
-- does NOT hold at function entry points or across basic block boundaries,
-- because the GHC calling convention does not guarantee that callers
-- zero-extend sub-word arguments. Therefore, any operation that is sensitive
@@ -688,7 +682,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
-- Next we compute `c`: The `%not` requires no extension of its operands, but
-- we must still truncate the result back down to 8-bits. Finally the `%shrl`
-- requires no extension and no truncate since we can assume that
--- `c` is zero-extended (it was produced by a truncateReg in the same block).
+-- `c` is zero-extended (it was produced by a truncateRegInplace in the same block).
--
-- TODO:
-- Don't use Width in Operands
@@ -931,7 +925,7 @@ getRegister' config plat expr
let w' = opRegWidth w
in code `snocOL`
MVN (OpReg w' dst) (OpReg w' reg) `appOL`
- truncateReg w' w dst -- See Note [Signed arithmetic on AArch64]
+ truncateRegInplace w' w dst -- See Note [Signed arithmetic on AArch64]
MO_S_Neg w -> negate code w reg
MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg))
@@ -952,7 +946,13 @@ getRegister' config plat expr
where fmt = intFormat w
-- Conversions
- MO_XX_Conv _from to -> swizzleRegisterRep (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))
@@ -1064,7 +1064,7 @@ getRegister' config plat expr
code `appOL`
code_sx `snocOL`
NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL`
- truncateReg w' w dst
+ truncateRegInplace w' w dst
ss_conv from to reg code =
let w' = opRegWidth (max from to)
@@ -1073,7 +1073,7 @@ getRegister' config plat expr
SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
-- At this point an 8- or 16-bit value would be sign-extended
-- to 32-bits. Truncate back down the final width.
- truncateReg w' to dst
+ truncateRegInplace w' to dst
-- Dyadic machops:
--
@@ -1220,7 +1220,7 @@ getRegister' config plat expr
code_y `appOL`
op (OpReg w dst) (OpReg w reg_x) op_y)
- -- A (potentially signed) integer operation.
+ -- A (potentially signed) integer operation that can have immediate arguments.
-- In the case of 8- and 16-bit signed arithmetic we must first
-- sign-extend both arguments to 32-bits.
-- See Note [Signed arithmetic on AArch64].
@@ -1230,6 +1230,7 @@ getRegister' config plat expr
-- compute x<m> <- x
-- compute x<o> <- y
-- <OP> x<n>, x<m>, x<o>
+ let w' = opRegWidth w
(reg_x, format_x, code_x) <- getSomeReg x
(op_y, format_y, code_y) <- case y of
CmmLit (CmmInt n w)
@@ -1241,12 +1242,11 @@ getRegister' config plat expr
massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
-- This is the width of the registers on which the operation
-- should be performed.
- let w' = opRegWidth w
return $ Any (intFormat w) $ \dst ->
code_x `appOL`
code_y `appOL`
op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`
- truncateReg w' w dst -- truncate back to the operand's original width
+ truncateRegInplace w' w dst -- truncate back to the operand's original width
-- A (potentially signed) integer operation.
-- In the case of 8- and 16-bit signed arithmetic we must first
@@ -1263,7 +1263,8 @@ getRegister' config plat expr
-- should be performed.
let w' = opRegWidth w
signExt r
- | not is_signed = return (r, nilOL)
+ -- See Note [Signed arithmetic on AArch64] and #27430
+ | not is_signed = truncateReg w w' r
| otherwise = signExtendReg w w' r
(reg_x_sx, code_x_sx) <- signExt reg_x
(reg_y_sx, code_y_sx) <- signExt reg_y
@@ -1274,7 +1275,7 @@ getRegister' config plat expr
code_x_sx `appOL`
code_y_sx `appOL`
op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`
- truncateReg w' w dst -- truncate back to the operand's original width
+ truncateRegInplace w' w dst -- truncate back to the operand's original width
floatOp w op = do
(reg_fx, format_x, code_fx) <- getFloatReg x
@@ -1897,17 +1898,35 @@ 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
r' <- getNewRegNat (intFormat w')
return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
--- | Instructions to truncate the value in the given register from width @w@
+-- | 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_from w_to r = do
+ case w_to of
+ W64 -> noop
+ W32
+ | w_from == W32 -> noop
+ | otherwise -> trunc MOV
+ W16 -> trunc UXTH
+ W8 -> trunc UXTB
+ _ -> panic "truncateReg:unexpectedWidth"
+ where
+ noop = return (r, nilOL)
+ trunc instr = do
+ 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'@.
-truncateReg :: Width -> Width -> Reg -> OrdList Instr
-truncateReg w w' r =
+truncateRegInplace :: Width -> Width -> Reg -> OrdList Instr
+truncateRegInplace w w' r =
case w of
W64 -> nilOL
W32
@@ -2352,7 +2371,7 @@ genCCall target dest_regs arg_regs = do
-- product, and hi gets the overflow (sign extension bits).
SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL`
ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL`
- truncateReg w' w lo `snocOL`
+ truncateRegInplace w' w lo `snocOL`
-- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'.
-- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive.
-- No overflow iff hi is the sign extension of lo:
@@ -2362,7 +2381,7 @@ genCCall target dest_regs arg_regs = do
-- NE to set nd = 1 when overflow occurred.
CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`
CSET (OpReg w' nd) NE `appOL`
- truncateReg w' w hi
+ truncateRegInplace w' w hi
-- Can't handle > 64 bit operands
| otherwise -> unsupported (MO_S_Mul2 w)
PrimTarget (MO_U_Mul2 w)
@@ -2412,7 +2431,7 @@ genCCall target dest_regs arg_regs = do
(OpImm (ImmInt $ widthInBits w)) -- lsb
(OpImm (ImmInt $ widthInBits w)) -- width to extract
`appOL`
- truncateReg W64 w lo
+ truncateRegInplace W64 w lo
)
| otherwise -> unsupported (MO_U_Mul2 w)
PrimTarget (MO_Clz w)
@@ -2898,6 +2917,7 @@ genCCall target dest_regs arg_regs = do
passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
+ -- readResults gpArgs fpArgs dest_regs reg_acc code_acc
readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock)
readResults _ _ [] _ accumCode = return accumCode
readResults [] _ _ _ _ = do
@@ -2915,7 +2935,14 @@ genCCall target dest_regs arg_regs = do
r_dst = getRegisterReg platform (CmmLocal dst)
if isFloatFormat format || isVecFormat format
then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
- else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))
+ else do
+ -- See [Signed arithmetic on AArch64]
+ -- Strictly speaking we don't have to here but err on the side of caution.
+ let !mov_instr = case w of
+ W8 -> UXTB
+ W16 -> UXTH
+ _ -> MOV
+ readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg))
unaryFloatOp w op arg_reg dest_reg = do
platform <- getPlatform
=====================================
testsuite/tests/codeGen/should_run/T27430.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE MagicHash #-}
-{-# OPTIONS_GHC -dno-typeable-binds -ddump-to-file -dsuppress-ticks -dsuppress-timestamps -ddump-stg-from-core -ddump-stg-final -ddump-cmm -ddump-cmm-raw -ddump-asm #-}
import GHC.Exts
import Data.Bits
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -296,4 +296,4 @@ test('aarch64-sxtw-run',
multi_compile_and_run,
['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])
-test('T27430', [req_c], compile_and_run, ['T27430_c.c'])
+test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36f760980d3f44cefc2358cd099013a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36f760980d3f44cefc2358cd099013a…
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