- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/interpolated-strings] 5 commits: Reorganize processChars functions
by Brandon Chinn (＠brandonchinn178) 11 Sep '26

11 Sep '26

Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: 6b902264 by Brandon Chinn at 2026-09-10T16:10:56-07:00 Reorganize processChars functions Move functions around, no code changes - - - - - 02af96b6 by Brandon Chinn at 2026-09-10T16:11:13-07:00 Always use processCharsSingle to get StringLexError - - - - - 96e73437 by Brandon Chinn at 2026-09-10T16:11:19-07:00 Add pprHsStringMulti, unify string ppr functions - - - - - deef7392 by Brandon Chinn at 2026-09-10T16:11:22-07:00 Break out Language.Haskell.Syntax.StringMeta - - - - - efa32059 by Brandon Chinn at 2026-09-10T16:12:07-07:00 Implement interpolated strings (#27592) - - - - - 80 changed files: - + changelog.d/string-interpolation - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/Lexer/String.x - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Expr.hs - + compiler/GHC/Rename/String.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - + compiler/Language/Haskell/Syntax/StringMeta.hs - compiler/ghc.cabal.in - docs/users_guide/exts/qualified_strings.rst - + docs/users_guide/exts/string_interpolation.rst - libraries/base/src/GHC/Essentials.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/Data/String/Experimental.hs - + libraries/ghc-experimental/src/Data/String/Interpolate/Builder/Experimental.hs - + libraries/ghc-experimental/src/Data/String/Interpolate/Class/Experimental.hs - + libraries/ghc-experimental/src/Data/String/Interpolate/Default/Experimental.hs - + libraries/ghc-experimental/src/Data/String/Interpolate/ShowS/Experimental.hs - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - + testsuite/tests/parser/should_fail/MultilineStringsEscapeOverflow.hs - + testsuite/tests/parser/should_fail/MultilineStringsEscapeOverflow.stderr - + testsuite/tests/parser/should_fail/StringInterpolationEscapeOverflow.hs - + testsuite/tests/parser/should_fail/StringInterpolationEscapeOverflow.stderr - + testsuite/tests/parser/should_fail/StringInterpolationExtraOpen.hs - + testsuite/tests/parser/should_fail/StringInterpolationExtraOpen.stderr - + testsuite/tests/parser/should_fail/StringInterpolationInPat.hs - + testsuite/tests/parser/should_fail/StringInterpolationInPat.stderr - + testsuite/tests/parser/should_fail/StringInterpolationInType.hs - + testsuite/tests/parser/should_fail/StringInterpolationInType.stderr - + testsuite/tests/parser/should_fail/StringInterpolationIncompleteExpr.hs - + testsuite/tests/parser/should_fail/StringInterpolationIncompleteExpr.stderr - + testsuite/tests/parser/should_fail/StringInterpolationInvalidExpr.hs - + testsuite/tests/parser/should_fail/StringInterpolationInvalidExpr.stderr - + testsuite/tests/parser/should_fail/StringInterpolationLineComment.hs - + testsuite/tests/parser/should_fail/StringInterpolationLineComment.stderr - + testsuite/tests/parser/should_fail/StringInterpolationNoDelimClose.hs - + testsuite/tests/parser/should_fail/StringInterpolationNoDelimClose.stderr - + testsuite/tests/parser/should_fail/StringInterpolationNoExpr.hs - + testsuite/tests/parser/should_fail/StringInterpolationNoExpr.stderr - + testsuite/tests/parser/should_fail/StringInterpolationNoExprClose.hs - + testsuite/tests/parser/should_fail/StringInterpolationNoExprClose.stderr - + testsuite/tests/parser/should_fail/StringInterpolationSmartQuotes.hs - + testsuite/tests/parser/should_fail/StringInterpolationSmartQuotes.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/parser/should_run/StringInterpolation.hs - + testsuite/tests/parser/should_run/StringInterpolation.stdout - + testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs - + testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout - testsuite/tests/parser/should_run/all.T - + testsuite/tests/qualified-strings/should_run/Example/SQL.hs - testsuite/tests/qualified-strings/should_run/all.T - + testsuite/tests/qualified-strings/should_run/qstrings_interpolation.hs - + testsuite/tests/qualified-strings/should_run/qstrings_interpolation.stdout - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e25d681710742482a159bb3a1e8090… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e25d681710742482a159bb3a1e8090… 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/interpolated-strings-refactor] 4 commits: Reorganize processChars functions
by Brandon Chinn (＠brandonchinn178) 11 Sep '26

11 Sep '26

Brandon Chinn pushed to branch wip/interpolated-strings-refactor at Glasgow Haskell Compiler / GHC Commits: 6b902264 by Brandon Chinn at 2026-09-10T16:10:56-07:00 Reorganize processChars functions Move functions around, no code changes - - - - - 02af96b6 by Brandon Chinn at 2026-09-10T16:11:13-07:00 Always use processCharsSingle to get StringLexError - - - - - 96e73437 by Brandon Chinn at 2026-09-10T16:11:19-07:00 Add pprHsStringMulti, unify string ppr functions - - - - - deef7392 by Brandon Chinn at 2026-09-10T16:11:22-07:00 Break out Language.Haskell.Syntax.StringMeta - - - - - 8 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/String.hs - compiler/GHC/Utils/Outputable.hs - + compiler/Language/Haskell/Syntax/StringMeta.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -87,7 +87,6 @@ import GHC.Parser.HaddockLex import GHC.Parser.Annotation import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () -import GHC.Parser.String import GHC.Builtin.WiredIn.Types ( unitTyCon, unitDataCon, sumTyCon, @@ -97,6 +96,7 @@ import GHC.Builtin.WiredIn.Types unrestrictedFunTyCon ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Language.Haskell.Syntax.StringMeta import Language.Haskell.Syntax.Text import qualified Data.Semigroup as Semi ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -141,6 +141,7 @@ import qualified GHC.Parser.Lexer.String as Lexer.String import GHC.Parser.String import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.StringMeta import Language.Haskell.Syntax.Text } ===================================== compiler/GHC/Parser/String.hs ===================================== @@ -6,10 +6,6 @@ module GHC.Parser.String ( lexString, lexMultilineString, - -- * StringMeta - StringMeta (..), - defaultStrMeta, - -- * Unicode smart quote helpers isDoubleSmartQuote, isSingleSmartQuote, @@ -20,7 +16,6 @@ import GHC.Prelude hiding (getChar) import Control.Arrow ((>>>)) import Control.Monad (when) import Data.Char (chr, ord) -import Data.Data (Data) import qualified Data.Foldable1 as Foldable1 import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (listToMaybe, mapMaybe) @@ -37,19 +32,13 @@ import GHC.Parser.CharClass ( ) import GHC.Parser.Errors.Types (LexErr (..)) import GHC.Utils.Panic (panic) -import Language.Haskell.Syntax.Module.Name (ModuleName) type BufPos = Int data StringLexError = StringLexError LexErr BufPos deriving (Show, Eq) lexString :: Int -> StringBuffer -> Either StringLexError String -lexString = lexStringWith processChars processChars - where - processChars :: HasChar c => [c] -> Either (c, LexErr) [c] - processChars = - collapseGaps - >>> resolveEscapes +lexString = lexStringWith (fromRight . processCharsSingle) -- ----------------------------------------------------------------------------- -- Lexing interface @@ -72,26 +61,27 @@ So what we'll do is do two passes. The first pass is optimistic; just convert to a plain String and process it. If this results in an error, we do a second pass, this time where each character is annotated with its position. Now, the error has all the information it needs. - -Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function, -but to help the specializer, we pass it in twice to concretize it for the two -types we actually use. -} -- | See Note [Lexing strings] -lexStringWith :: - ([Char] -> Either (Char, LexErr) [Char]) - -> ([CharPos] -> Either (CharPos, LexErr) [CharPos]) - -> Int - -> StringBuffer - -> Either StringLexError String -lexStringWith processChars processCharsPos len buf = +lexStringWith :: (String -> Maybe String) -> Int -> StringBuffer -> Either StringLexError String +lexStringWith processChars len buf = case processChars $ bufferChars buf len of - Right s -> Right s - Left _ -> - case processCharsPos $ bufferLocatedChars buf len of - Right _ -> panic "expected lex error on second pass" - Left ((_, pos), e) -> Left $ StringLexError e pos + Just s -> Right s + Nothing -> do + validateString len buf -- should return Left + panic "expected lex error on second pass" + +-- | Find any lexical errors in the string. +-- +-- Can validate both single- and multi-line strings, since multi-line strings +-- have the same validation logic as single-line strings, and none of the +-- multi-line string processing steps affect the validity of the string. +validateString :: Int -> StringBuffer -> Either StringLexError () +validateString len buf = + case processCharsSingle $ bufferLocatedChars buf len of + Right _ -> Right () + Left ((_, pos), e) -> Left $ StringLexError e pos class HasChar c where getChar :: c -> Char @@ -128,6 +118,11 @@ bufferLocatedChars initialBuf len = go initialBuf -- ----------------------------------------------------------------------------- -- Lexing phases +processCharsSingle :: HasChar c => [c] -> Either (c, LexErr) [c] +processCharsSingle = + collapseGaps + >>> resolveEscapes + -- | Collapse all string gaps in the given input. -- -- Iterates through the input in `go` until we encounter a backslash. The @@ -185,6 +180,9 @@ resolveEscapes = go nilOL Left (c, e) -> Left (c, e) c : cs -> go (acc `snocOL` c) cs +resolveEscapesMaybe :: HasChar c => [c] -> Maybe [c] +resolveEscapesMaybe = fromRight . resolveEscapes + -- ----------------------------------------------------------------------------- -- Escape characters @@ -284,20 +282,7 @@ isSingleSmartQuote = \case _ -> False -- ----------------------------------------------------------------------------- --- StringMeta - -data StringMeta = StringMeta - { strMetaMultiline :: Bool - , strMetaQualified :: Maybe ModuleName - } - deriving (Show, Data) - -defaultStrMeta :: StringMeta -defaultStrMeta = - StringMeta - { strMetaMultiline = False - , strMetaQualified = Nothing - } +-- QualifiedStrings {- Note [Implementation of QualifiedStrings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -353,88 +338,60 @@ to standard string literals for overlap checking, ensuring that -- and rejoining lines, and instead manually find newline characters, -- for performance. lexMultilineString :: Int -> StringBuffer -> Either StringLexError String -lexMultilineString = lexStringWith processChars processChars +lexMultilineString = lexStringWith processCharsMulti + +processCharsMulti :: String -> Maybe String +processCharsMulti = + collapseGaps -- Step 1 + >>> normalizeEOL + >>> expandLeadingTabs -- Step 3 + >>> rmCommonWhitespacePrefix -- Step 4 + >>> collapseOnlyWsLines -- Step 5 + >>> rmFirstNewline -- Step 7a + >>> rmLastNewline -- Step 7b + >>> resolveEscapesMaybe -- Step 8 + +-- Normalize line endings to LF. The spec dictates that lines should be +-- split on newline characters and rejoined with ``\n``. But because we +-- aren't actually splitting/rejoining, we'll manually normalize here +normalizeEOL :: String -> String +normalizeEOL = go where - processChars :: HasChar c => [c] -> Either (c, LexErr) [c] - processChars = - collapseGaps -- Step 1 - >>> normalizeEOL - >>> expandLeadingTabs -- Step 3 - >>> rmCommonWhitespacePrefix -- Step 4 - >>> collapseOnlyWsLines -- Step 5 - >>> rmFirstNewline -- Step 7a - >>> rmLastNewline -- Step 7b - >>> resolveEscapes -- Step 8 - - -- Normalize line endings to LF. The spec dictates that lines should be - -- split on newline characters and rejoined with ``\n``. But because we - -- aren't actually splitting/rejoining, we'll manually normalize here - normalizeEOL :: HasChar c => [c] -> [c] - normalizeEOL = - let go = \case - Char '\r' : c@(Char '\n') : cs -> c : go cs - c@(Char '\r') : cs -> setChar '\n' c : go cs - c@(Char '\f') : cs -> setChar '\n' c : go cs - c : cs -> c : go cs - [] -> [] - in go - - -- expands all tabs, since the lexer will verify that tabs can only appear - -- as leading indentation - expandLeadingTabs :: HasChar c => [c] -> [c] - expandLeadingTabs = - let go !col = \case - c@(Char '\t') : cs -> - let fill = 8 - (col `mod` 8) - in replicate fill (setChar ' ' c) ++ go (col + fill) cs - c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs - [] -> [] - in go 0 + go = \case + Char '\r' : c@(Char '\n') : cs -> c : go cs + c@(Char '\r') : cs -> setChar '\n' c : go cs + c@(Char '\f') : cs -> setChar '\n' c : go cs + c : cs -> c : go cs + [] -> [] + +-- | Expands all tabs blindly, since the lexer will verify that tabs can only appear +-- as leading indentation +expandLeadingTabs :: String -> String +expandLeadingTabs = go 0 + where + go !col = \case + '\t' : cs -> + let fill = 8 - (col `mod` 8) + in replicate fill ' ' ++ go (col + fill) cs + c : cs -> c : go (if c == '\n' then 0 else col + 1) cs + [] -> [] + +rmCommonWhitespacePrefix :: String -> String +rmCommonWhitespacePrefix cs0 = go cs0 + where + commonWSPrefix = getCommonWsPrefix cs0 - rmCommonWhitespacePrefix :: HasChar c => [c] -> [c] - rmCommonWhitespacePrefix cs0 = - let commonWSPrefix = getCommonWsPrefix (map getChar cs0) - go = \case - c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs) - c : cs -> c : go cs - [] -> [] - -- drop x characters from the string, or up to a newline, whichever - -- comes first - dropLine !x = \case - cs | x <= 0 -> cs - cs@(Char '\n' : _) -> cs - _ : cs -> dropLine (x - 1) cs - [] -> [] - in go cs0 - - collapseOnlyWsLines :: HasChar c => [c] -> [c] - collapseOnlyWsLines = - let go = \case - c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs' - c : cs -> c : go cs - [] -> [] - checkAllWs = \case - -- got all the way to a newline or the end of the string, return - cs@(Char '\n' : _) -> Just cs - cs@[] -> Just cs - -- found whitespace, continue - Char c : cs | is_space c -> checkAllWs cs - -- anything else, stop - _ -> Nothing - in go - - rmFirstNewline :: HasChar c => [c] -> [c] - rmFirstNewline = \case - Char '\n' : cs -> cs - cs -> cs - - rmLastNewline :: HasChar c => [c] -> [c] - rmLastNewline = - let go = \case - [] -> [] - [Char '\n'] -> [] - c : cs -> c : go cs - in go + go = \case + c@'\n' : cs -> c : go (dropLine commonWSPrefix cs) + c : cs -> c : go cs + [] -> [] + + -- drop x characters from the string, or up to a newline, whichever comes first + dropLine !x = \case + cs | x <= 0 -> cs + cs@('\n' : _) -> cs + _ : cs -> dropLine (x - 1) cs + [] -> [] -- | See step 4 in Note [Multiline string literals] -- @@ -450,6 +407,36 @@ getCommonWsPrefix s = . drop 1 -- ignore first line in calculation $ lines s +collapseOnlyWsLines :: String -> String +collapseOnlyWsLines = go + where + go = \case + c@'\n' : cs | Just cs' <- checkAllWs cs -> c : go cs' + c : cs -> c : go cs + [] -> [] + + checkAllWs = \case + -- got all the way to a newline or the end of the string, return + cs@('\n' : _) -> Just cs + cs@[] -> Just cs + -- found whitespace, continue + c : cs | is_space c -> checkAllWs cs + -- anything else, stop + _ -> Nothing + +rmFirstNewline :: String -> String +rmFirstNewline = \case + '\n' : cs -> cs + cs -> cs + +rmLastNewline :: String -> String +rmLastNewline = go + where + go = \case + [] -> [] + ['\n'] -> [] + c : cs -> c : go cs + {- Note [Multiline string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -488,3 +475,9 @@ It's more precisely defined with the following algorithm: * Lines with only whitespace characters 3. Calculate the longest prefix of whitespace shared by all lines in the remaining list -} + +-- ----------------------------------------------------------------------------- +-- Other utilities + +fromRight :: Either e a -> Maybe a +fromRight = either (const Nothing) Just ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -61,7 +61,10 @@ module GHC.Utils.Outputable ( pprDebugAndThen, pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsBytes, + pprHsChar, + pprHsString, pprHsString', + pprHsStringMulti, pprHsStringMulti', + pprHsBytes, primFloatSuffix, primCharSuffix, primDoubleSuffix, primInt8Suffix, primWord8Suffix, @@ -165,7 +168,7 @@ import Data.Void import Control.DeepSeq (NFData(rnf)) import GHC.Fingerprint -import GHC.Show ( showMultiLineString ) +import GHC.Show ( showLitString ) import GHC.Utils.Exception import GHC.Exts (oneShot) @@ -1355,14 +1358,42 @@ pprHsChar :: Char -> SDoc pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) | otherwise = text (show c) --- | Special combinator for showing string literals. +-- | Special combinator for showing single-line string literals. pprHsString :: String -> SDoc -pprHsString fs = vcat (map text (showMultiLineString fs)) +pprHsString fs = char '"' <> pprHsString' fs <> char '"' + +-- | Like 'pprHsString' except without the outer quotes. +pprHsString' :: String -> SDoc +pprHsString' = vcat . map text . showLitStringLines + where + -- Like 'GHC.Show.showMultiLineString', except without wrapping in quotes + showLitStringLines = go id + where + go pre s = + case break (== '\n') s of + (l, '\n':s'@(_:_)) -> (pre $ showLitString l "\\n\\") : go ('\\' :) s' + (l, '\n':[]) -> [pre $ showLitString l "\\n"] + (l, _) -> [pre $ showLitString l ""] + +-- | Special combinator for showing multi-line string literals. +pprHsStringMulti :: FastString -> SDoc +pprHsStringMulti fs = text "\"\"\"" <> pprHsString' (unpackFS fs) <> text "\"\"\"" + +-- | Like 'pprHsStringMulti' except without the outer quotes. +pprHsStringMulti' :: String -> SDoc +pprHsStringMulti' = vcat . map text . showLitStringMultiline + where + showLitChars :: String -> ShowS + showLitChars [] s = s + showLitChars (c : cs) s = showLitChar c (showLitChars cs s) + + showLitStringMultiline :: String -> [String] + showLitStringMultiline = map (flip showLitChars "") . lines -- | Special combinator for showing bytestring literals. pprHsBytes :: ByteString -> SDoc pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs - in vcat (map text (showMultiLineString escaped)) <> char '#' + in char '"' <> pprHsString' escaped <> text "\"#" where escape :: Word8 -> String escape w = let c = chr (fromIntegral w) in if isAscii c ===================================== compiler/Language/Haskell/Syntax/StringMeta.hs ===================================== @@ -0,0 +1,27 @@ +module Language.Haskell.Syntax.StringMeta ( + StringMeta (..), + defaultStrMeta, +) where + +import Prelude + +import Language.Haskell.Syntax.Module.Name (ModuleName) + +-- libraries: +import Data.Data (Data) + +-- ----------------------------------------------------------------------------- +-- StringMeta + +data StringMeta = StringMeta + { strMetaMultiline :: Bool + , strMetaQualified :: Maybe ModuleName + } + deriving (Show, Data) + +defaultStrMeta :: StringMeta +defaultStrMeta = + StringMeta + { strMetaMultiline = False + , strMetaQualified = Nothing + } ===================================== compiler/ghc.cabal.in ===================================== @@ -1062,6 +1062,7 @@ Library Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity + Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -28,5 +28,6 @@ Language.Haskell.Syntax.Lit Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity +Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -303,5 +303,6 @@ Language.Haskell.Syntax.Lit Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity +Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1dc1c81186579d245b2f3e3129154a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1dc1c81186579d245b2f3e3129154a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/no-minimal-for-bitsize
by Bodigrim (＠Bodigrim) 11 Sep '26

11 Sep '26

Bodigrim pushed new branch wip/no-minimal-for-bitsize at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/no-minimal-for-bitsize 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/az/exactprint-main-loop-note] 11 commits: Reorder cmm decls in HeapStackCheck for a better logical grouping
by Alan Zimmerman (＠alanz) 11 Sep '26

11 Sep '26

Alan Zimmerman pushed to branch wip/az/exactprint-main-loop-note at Glasgow Haskell Compiler / GHC Commits: 430967ab by Duncan Coutts at 2026-09-09T11:07:01+01:00 Reorder cmm decls in HeapStackCheck for a better logical grouping And put more section headers in to deliniate the groups. We're about to add more here, so better to organise it first. - - - - - 344080fd by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add raisePrimIOException and add it to RTS<->ghc-internal API The raisePrimIOException is a new helper function that I/O primops will use to help them report I/O errors. This is implemented in Haskell (since that's a lot easier), but has a calling convention that is easy(ish) to use from Cmm in the I/O primops. So we add it to the RTS API struct, and since we'll use it from Cmm we also need a field accessor macro for cmm (in deriveConstants). See the Note about how we cannot have nice things due to async exceptions and thunks preventing us from using catch. - - - - - cfdb3399 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add new blocking functions for I/O primops See the Note [Thread blocking for new I/O primops], and the Note [Calling convention for raisePrimIOException]. The point is, it will allow us to report synchronous exceptions from I/O primops, and do so much more flexibly. Previously the I/O managers could only report async exceptions and only nullary exceptions. This was OK historically, but no good as we add more I/O managers and expand the range of I/O operations we support. - - - - - f09c09d8 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Change the encoding of results from the I/O manager to I/O primops Previously we just had async continue or heap overflow. We now extend what we can report with synchronous success, and synchronous failure with an errno. See Note [Encoding of result of I/O manager operations] We don't use these two new cases yet, but we will. In particular an epoll I/O manager needs to be able to report synchronous success or failure for waitRead#/waitWrite#. - - - - - 30f074d9 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch waitRead/Write# to use new blocking return frames and update the I/O managers to set the result before resuming the blocked threads. This makes it possible for I/O managers to report synchronous exceptions from the I/O primops, but that will be done in a subsequent commit. - - - - - a8786ced by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch Poll and Select I/O managers to report sync exceptions rather than using raiseAsync with blockedOnBadFD_closure. This uses the new mechanism in the blocking frame return code to report synchronous exceptions. - - - - - 7a9df79a by Duncan Coutts at 2026-09-09T11:07:01+01:00 Remove now-unused blockedOnBadFD It was previously thrown by the select and poll I/O managers, but now they use raisePrimIOException (with an EBADF errno). - - - - - 6b0424e3 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Improve the docs for delay# waitRead# and waitWrite# Document that the waitRead/Write# can throw exceptions (this was true before too), and that all of them are async exception cancellation points. - - - - - afeb2c30 by Duncan Coutts at 2026-09-09T20:08:58-04:00 Enable printf warnings for trace functions and fix resulting warnings Most of the existing printf-style functions are annotated with attributes to enable gcc/clang warnings for the printf format string, but several trace functions in Trace.h were missing this annotation. Enable them, and fix the resulting warnings. - - - - - 9a442c93 by Alan Zimmerman at 2026-09-09T20:09:36-04:00 EPA: Exact print ConDeclGADT without custom enterAnn !16321 brought in explicit capture of parens in a ConDeclGADT. The ExactPrint update introduced a modification of the fundamental function in exact printing, `enterAnn`, by splitting it into a version allowing injection of functionality normally handled by the ExactPrint class methods. This commit refactors that code, to restore the prior `enterAnn` version, by following the convention in ExactPrint of introducing a helper data structure with its own `ExactPrint` instance to achieve the same effect. - - - - - 9867fdad by Alan Zimmerman at 2026-09-10T19:22:00+00:00 EPA: Add a Note for the exact print main loop - - - - - 36 changed files: - compiler/GHC/Builtin/primops.txt.pp - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - rts/Capability.c - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/Messages.c - rts/Prelude.h - rts/PrimOps.cmm - rts/Printer.c - rts/STM.c - rts/Schedule.c - rts/Sparks.c - rts/StableName.c - rts/ThreadPaused.c - rts/Threads.c - rts/Trace.h - rts/include/rts/RtsToHsIface.h - rts/include/stg/MiscClosures.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - rts/posix/Timeout.c - rts/sm/Compact.c - rts/sm/GC.c - rts/sm/GCUtils.c - rts/sm/MBlock.c - rts/sm/NonMoving.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - rts/sm/Sweep.c - utils/check-exact/ExactPrint.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/08741965280a44feb53e6627f98de2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/08741965280a44feb53e6627f98de2… 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) 11 Sep '26

11 Sep '26

Duncan Coutts pushed to branch wip/dcoutts/io-manager-selectbis at Glasgow Haskell Compiler / GHC Commits: 0ef91513 by Duncan Coutts at 2026-09-10T20:03:51+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. - - - - - e8fb6db1 by Duncan Coutts at 2026-09-10T20:03:51+01:00 Document the new select I/O manager in the user guide in the RTS section about I/O managers. And add a changelog entry. - - - - - 9b0d051f by Duncan Coutts at 2026-09-10T20:03:51+01:00 Minor updates in the poll I/O manager to keep in sync This keeps it in sync with select one. The changes are based on code review while implementing the new select I/O manager. The two I/O managers are so similar in structure that it makes sense to try to minimise the diff between them. This should aid understanding, and fixes to both in future. - - - - - a8f6ec1f by Duncan Coutts at 2026-09-10T20:03:51+01:00 Refactor (and rename) removeFromQueues, to simplify I/O managers Rename it to unblockAndAppendToRunQueue which better reflects what it is intended to do. The post-condition for unblockAndAppendToRunQueue is that the TSO is on the run queue or it is in the process of migrating to another cap. Previously it achieved that by always directly adding the TSO to the run queue itself. But this actually made things more complicated for the I/O managers, because it meant they needed a separate code path for notifying for cancellation compared to notifying for completion. The general notification code would always add the TSO to the run queue itself. So the improvement is to allow different cases in unblockAndAppendToRunQueue to achieve the same outcome in different ways: either directly adding to the run queue or calling helper functions that do so themselves. This then allows the new I/O managers to share code between the sync and async cancellation, and to reuse their notifyIOCompletion helpers for cancellation. This avoids a source of bugs where the completion path may be updated but the cancellation path may be forgotten, or similarly in future for sync/async operations. Update all the existing in-RTS I/O managers, and the posix timeout code. - - - - - 471450f4 by Duncan Coutts at 2026-09-10T20:03:51+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. - - - - - 18 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/RTS/Flags.hsc - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/RaiseAsync.c - 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 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== changelog.d/select-io-manager ===================================== @@ -0,0 +1,19 @@ +section: rts +issues: #27519 +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 ===================================== @@ -393,10 +393,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/RTS/Flags.hsc ===================================== @@ -182,6 +182,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,11 @@ #include "posix/Signals.h" #endif +#if defined(IOMGR_ENABLED_SELECTBIS) +#include "posix/SelectBis.h" +#include "posix/Timeout.h" +#endif + #if defined(IOMGR_ENABLED_POLL) #include "posix/Poll.h" #include "posix/Timeout.h" @@ -117,6 +122,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 +239,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 +259,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 +312,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 +372,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 +411,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); @@ -464,6 +501,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. */ @@ -555,8 +593,14 @@ 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; @@ -600,6 +644,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); @@ -659,6 +708,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); @@ -693,6 +748,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); @@ -734,6 +795,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); @@ -783,6 +850,10 @@ IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, return IOSubmitResultAsyncContinue; } #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: return syncIOWaitReadyPoll(iomgr, tso, rw, fd); @@ -803,6 +874,13 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso) &iomgr->blocked_queue_hd, &iomgr->blocked_queue_tl, tso); + appendToRunQueue(iomgr->cap, tso); + RELEASE_STORE(&tso->why_blocked, NotBlocked); + break; +#endif +#if defined(IOMGR_ENABLED_SELECTBIS) + case IO_MANAGER_SELECTBIS: + syncIOCancelSelectBis(iomgr, tso); break; #endif #if defined(IOMGR_ENABLED_POLL) @@ -817,11 +895,14 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso) &iomgr->blocked_queue_tl, tso); abandonWorkRequest(tso->block_info.async_reqID); + appendToRunQueue(iomgr->cap, tso); + RELEASE_STORE(&tso->why_blocked, NotBlocked); break; #endif default: barf("syncIOCancel not supported for I/O manager %d", iomgr_type); } + ASSERT(tso->why_blocked == NotBlocked); } @@ -848,8 +929,14 @@ 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) @@ -883,10 +970,18 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso) case IO_MANAGER_SELECT: ASSERT(tso->why_blocked == (BlockedOnDelay | BlockInfoForceNonClosure)); removeThreadFromQueue(iomgr->cap, &iomgr->sleeping_queue, tso); + appendToRunQueue(iomgr->cap, tso); + RELEASE_STORE(&tso->why_blocked, NotBlocked); 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 @@ -900,6 +995,7 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso) default: barf("syncDelayCancel not supported for I/O manager %d", iomgr_type); } + ASSERT(tso->why_blocked == NotBlocked); } ===================================== 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 @@ -353,11 +367,13 @@ enum IOSubmitResultCodes { /* Called from CMM primop */ IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd); +/* Cancel the I/O the TSO is blocked on and add the TSO to the run queue */ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso); /* Called from CMM primop */ bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay); +/* Cancel the timeout the TSO is blocked on and add the TSO to the run queue */ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso); #if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_WIN32_LEGACY) ===================================== rts/IOManagerInternals.h ===================================== @@ -14,12 +14,20 @@ #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 +54,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; +#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/RaiseAsync.c ===================================== @@ -28,7 +28,7 @@ static void blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg); -static void removeFromQueues(Capability *cap, StgTSO *tso); +static void unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso); static void removeFromMVarBlockedQueue (StgTSO *tso); @@ -62,8 +62,10 @@ throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception, return; } - // Remove it from any blocking queues - removeFromQueues(cap,tso); + // Remove it from any blocking queues and add it to the run queue + unblockAndAppendToRunQueue(cap,tso); + ASSERT(tso->why_blocked == NotBlocked || + tso->why_blocked == ThreadMigrating); raiseAsync(cap, tso, exception, stop_at_atomically, stop_here); } @@ -471,7 +473,7 @@ check_target: blockedThrowTo(cap,target,msg); return THROWTO_BLOCKED; } else { - removeFromQueues(cap,target); + unblockAndAppendToRunQueue(cap,target); raiseAsync(cap, target, msg->exception, false, NULL); return THROWTO_SUCCESS; } @@ -612,16 +614,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso) tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE; } -/* ----------------------------------------------------------------------------- - Remove a thread from blocking queues. - - This is for use when we raise an exception in another thread, which - may be blocked. - - Precondition: we have exclusive access to the TSO, via the same set - of conditions as throwToSingleThreaded() (c.f.). - -------------------------------------------------------------------------- */ - +// Helper for unblockAndAppendToRunQueue static void removeFromMVarBlockedQueue (StgTSO *tso) { @@ -664,13 +657,24 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +/* ----------------------------------------------------------------------------- + Remove a thread from blocking queues (if any) and add it to the run queue + (if it wasn't on the run queue already). + + This is for use when we raise an exception in another thread, which + may be blocked. + + Precondition: we have exclusive access to the TSO, via the same set + of conditions as throwToSingleThreaded() (c.f.). + -------------------------------------------------------------------------- */ + static void -removeFromQueues(Capability *cap, StgTSO *tso) +unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso) { switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) { - case NotBlocked: - case ThreadMigrating: + case NotBlocked: // Already on the run queue + case ThreadMigrating: // Not added to the run queue return; case BlockedOnSTM: @@ -680,16 +684,16 @@ removeFromQueues(Capability *cap, StgTSO *tso) // perhaps have a debugging test to make sure that this really // happens and that the 'zombie' transaction does not get // committed. - goto done; + break; case BlockedOnMVar: case BlockedOnMVarRead: removeFromMVarBlockedQueue(tso); - goto done; + break; case BlockedOnBlackHole: // nothing to do - goto done; + break; case BlockedOnMsgThrowTo: { @@ -709,18 +713,19 @@ removeFromQueues(Capability *cap, StgTSO *tso) case BlockedOnDoProc: // These blocking reasons are only used by some I/O managers syncIOCancel(cap->iomgr, tso); - goto done; + return; case BlockedOnDelay: // This blocking reasons is only used by some I/O managers syncDelayCancel(cap->iomgr, tso); - goto done; + return; default: - barf("removeFromQueues: %d", tso->why_blocked); + barf("unblockAndAppendToRunQueue: %d", tso->why_blocked); } - done: + // The cases above that use return add the TSO to the run queue themselves + // (or don't need to). For the rest (that use break) we do it here. appendToRunQueue(cap, tso); RELEASE_STORE(&tso->why_blocked, NotBlocked); } ===================================== 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 ===================================== @@ -132,7 +132,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; @@ -222,20 +222,7 @@ 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); - setTsoIOOpOutcome(tso, aiop->outcome, aiop->result); - /* 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). - */ - - /* 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); - } + asyncIOCancelPoll(iomgr, aiop); } @@ -246,29 +233,14 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop) * 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) { - 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) @@ -349,6 +321,8 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions) if (aiop_poll_table[i].revents) { StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i); + ASSERT(aiop->outcome == IOOpOutcomeInFlight); + /* We do need to handle POLLNVAL, but we do not need to do anything * special for POLLERR or POLLHUP. (See man poll for details). * The calling thread will typically try to do I/O after waiting @@ -364,26 +338,14 @@ 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 { - /* You'd expect incrementing the poll table index to be - * unconditional, but we don't increment the index if we did - * process the entry, because using removeCompactClosureTable - * means we'll move an entry from the end into the same index. + /* 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++; } @@ -564,6 +526,7 @@ bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) return !interrupt; } + static void reportPollError(int res, nfds_t nfds) { if (errno == EINVAL) { @@ -619,4 +582,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,668 @@ +/* ----------------------------------------------------------------------------- + * + * (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 "Trace.h" + +#include "SelectBis.h" +#include "RtsSignals.h" + +#include <errno.h> +#include <sys/select.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 is 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 notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop); +static void removeFromTables(CapIOManager *iomgr, int i); +static bool fdInSelectRange(int fd); +static int collectFdSets(CapIOManager *iomgr); +static void processBadFds(CapIOManager *iomgr); +static void reportSelectError(void) STG_NORETURN; + + +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"); +} + + +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 +} + + +/* Used to implement syncIOWaitReady. */ +IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso, + IOReadOrWrite rw, HsInt fd) +{ + StgAsyncIOOp *aiop; + aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp)); + if (RTS_UNLIKELY(aiop == NULL)) return IOSubmitResultHeapOverflow; + 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->block_info.aiop = aiop; + RELEASE_STORE(&tso->why_blocked, rw == IORead ? BlockedOnRead + : BlockedOnWrite); + return asyncIOWaitReadySelectBis(iomgr, aiop, rw, fd); +} + +IOSubmitResult 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 IOSubmitResultHeapOverflow; + } + + if (RTS_UNLIKELY(!fdInSelectRange(fd))) { + /* Synchronous error */ + aiop->outcome = IOOpOutcomeFailed; + aiop->error = EBADF; + return -EBADF; + }; + + 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 + }; + + return IOSubmitResultAsyncContinue; +} + + +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); + asyncIOCancelSelectBis(iomgr, 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. + */ + 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); + + /* Fill in the outcome and result/error on the TSO's stack frame */ + setTsoIOOpOutcome(tso, aiop->outcome, aiop->result); + pushOnRunQueue(iomgr->cap, tso); + RELEASE_STORE(&tso->why_blocked, NotBlocked); + + /* 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)) { + 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; + + ASSERT(aiop->outcome == IOOpOutcomeInFlight); + + if (rw == IORead ? FD_ISSET(fd, iomgr->rfds) + : FD_ISSET(fd, iomgr->wfds)) { + aiop->outcome = IOOpOutcomeSuccess; + aiop->result = 0; + removeFromTables(iomgr, i); + notifyIOCompletion(iomgr, aiop); + n--; + } 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++; + } + } + 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) { + /* There is no I/O ready. We'll return to the scheduler. */ + + } else if (res > 0) { + int ncompletions = res; + ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1); + 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(); + } + } +} + + +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 { + /* There is either pending I/O or pending timers. */ + ASSERT(!isEmptyTimeoutQueue(iomgr->timeout_queue) || + !isEmptyClosureTable(&iomgr->aiop_table)); + + 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); + + /* 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) { + /* 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) { + int ncompletions = res; + ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1); + 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. 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. + */ +#if defined(RTS_USER_SIGNALS) + if (startPendingSignalHandlers(iomgr->cap)) break; +#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(void) +{ + 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 within range for select(). + */ +static bool fdInSelectRange(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,62 @@ +/* ----------------------------------------------------------------------------- + * + * (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 */ +IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso, + IOReadOrWrite rw, HsInt fd); +void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso); + +/* Asynchronous operations */ +IOSubmitResult 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,8 @@ /* 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_SELECTBIS) \ + || defined(IOMGR_ENABLED_POLL) bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay) { @@ -68,14 +70,13 @@ void syncDelayCancelTimeout(CapIOManager *iomgr, StgTSO *tso) deleteTimeoutQueue(&iomgr->timeout_queue, timeout); + appendToRunQueue(iomgr->cap, tso); + RELEASE_STORE(&tso->why_blocked, NotBlocked); + /* the timeout is no longer accessible from anywhere (except here) */ IF_NONMOVING_WRITE_BARRIER_ENABLED { updateRemembSetPushClosure(iomgr->cap, (StgClosure *)timeout); } - - /* 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). - */ } static void notifyTimeoutCompletion(CapIOManager *iomgr, StgTimeout *timeout); @@ -222,5 +223,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) || ... etc ===================================== 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 ===================================== @@ -568,6 +568,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 @@ -583,6 +584,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 ===================================== @@ -7861,7 +7861,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 :: * ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -7864,7 +7864,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/31a44a61b4254f052599140a6fdcca… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31a44a61b4254f052599140a6fdcca… 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/substitution-via-mapper] 17 commits: Reorder cmm decls in HeapStackCheck for a better logical grouping
by Simon Peyton Jones (＠simonpj) 11 Sep '26

11 Sep '26

Simon Peyton Jones pushed to branch wip/substitution-via-mapper at Glasgow Haskell Compiler / GHC Commits: 430967ab by Duncan Coutts at 2026-09-09T11:07:01+01:00 Reorder cmm decls in HeapStackCheck for a better logical grouping And put more section headers in to deliniate the groups. We're about to add more here, so better to organise it first. - - - - - 344080fd by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add raisePrimIOException and add it to RTS<->ghc-internal API The raisePrimIOException is a new helper function that I/O primops will use to help them report I/O errors. This is implemented in Haskell (since that's a lot easier), but has a calling convention that is easy(ish) to use from Cmm in the I/O primops. So we add it to the RTS API struct, and since we'll use it from Cmm we also need a field accessor macro for cmm (in deriveConstants). See the Note about how we cannot have nice things due to async exceptions and thunks preventing us from using catch. - - - - - cfdb3399 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Add new blocking functions for I/O primops See the Note [Thread blocking for new I/O primops], and the Note [Calling convention for raisePrimIOException]. The point is, it will allow us to report synchronous exceptions from I/O primops, and do so much more flexibly. Previously the I/O managers could only report async exceptions and only nullary exceptions. This was OK historically, but no good as we add more I/O managers and expand the range of I/O operations we support. - - - - - f09c09d8 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Change the encoding of results from the I/O manager to I/O primops Previously we just had async continue or heap overflow. We now extend what we can report with synchronous success, and synchronous failure with an errno. See Note [Encoding of result of I/O manager operations] We don't use these two new cases yet, but we will. In particular an epoll I/O manager needs to be able to report synchronous success or failure for waitRead#/waitWrite#. - - - - - 30f074d9 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch waitRead/Write# to use new blocking return frames and update the I/O managers to set the result before resuming the blocked threads. This makes it possible for I/O managers to report synchronous exceptions from the I/O primops, but that will be done in a subsequent commit. - - - - - a8786ced by Duncan Coutts at 2026-09-09T11:07:01+01:00 Switch Poll and Select I/O managers to report sync exceptions rather than using raiseAsync with blockedOnBadFD_closure. This uses the new mechanism in the blocking frame return code to report synchronous exceptions. - - - - - 7a9df79a by Duncan Coutts at 2026-09-09T11:07:01+01:00 Remove now-unused blockedOnBadFD It was previously thrown by the select and poll I/O managers, but now they use raisePrimIOException (with an EBADF errno). - - - - - 6b0424e3 by Duncan Coutts at 2026-09-09T11:07:01+01:00 Improve the docs for delay# waitRead# and waitWrite# Document that the waitRead/Write# can throw exceptions (this was true before too), and that all of them are async exception cancellation points. - - - - - afeb2c30 by Duncan Coutts at 2026-09-09T20:08:58-04:00 Enable printf warnings for trace functions and fix resulting warnings Most of the existing printf-style functions are annotated with attributes to enable gcc/clang warnings for the printf format string, but several trace functions in Trace.h were missing this annotation. Enable them, and fix the resulting warnings. - - - - - 9a442c93 by Alan Zimmerman at 2026-09-09T20:09:36-04:00 EPA: Exact print ConDeclGADT without custom enterAnn !16321 brought in explicit capture of parens in a ConDeclGADT. The ExactPrint update introduced a modification of the fundamental function in exact printing, `enterAnn`, by splitting it into a version allowing injection of functionality normally handled by the ExactPrint class methods. This commit refactors that code, to restore the prior `enterAnn` version, by following the convention in ExactPrint of introducing a helper data structure with its own `ExactPrint` instance to achieve the same effect. - - - - - 2168462f by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Try using TyCoMapper for substitutions - - - - - d4ee89b1 by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Implement substitution via TyCoMapper This is a significant bit of refactoring. The dependencies look like this, where each module depends on one above Defines Needs --------------------------------------------------- GHC.Core.TyCo.Rep Type, Coercion TyCoFolder GHC.Core.TyCo.FVs Free-var finders TyCoFolder GHC.Core.TyCo.Make Lots of mkX functions Free vars TyCoMapper GHC.Core.TyCo.Subst Substitution TyCoMapper, mkX functions GHC.Core.Type coreView, typeKind Substitution coercionKind GHC.Core.TyCo.Compare Comparison coreView Some `mkX` functions (such as `mkLRCo`, `mkInstCo`, `mkCastTy`) use substitution, and so are defined in GHC.Core.Type via a hs-boot import. - - - - - 9d88c7ba by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Make substitution strict It's nice that it is so easy to do so - - - - - 98f18698 by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Wibbles - - - - - dd2e2a2e by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Wibbles - - - - - 9bd8afe1 by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Wibble imports - - - - - b4812d8b by Simon Peyton Jones at 2026-09-10T17:31:49+01:00 Wibbles - - - - - 71 changed files: - compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Reduction.hs - compiler/GHC/Core/Seq.hs - compiler/GHC/Core/TyCo/FVs.hs - + compiler/GHC/Core/TyCo/Make.hs - + compiler/GHC/Core/TyCo/Make.hs-boot - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Rep.hs-boot - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Type.hs-boot - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Stg/EnforceEpt/TagSig.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Cpr.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Name/Env.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Map.hs - compiler/GHC/Types/Unique/Set.hs - compiler/GHC/Types/Var/Set.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - + compiler/GHC/Utils/StrictIdentity.hs - compiler/ghc.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - rts/Capability.c - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/Messages.c - rts/Prelude.h - rts/PrimOps.cmm - rts/Printer.c - rts/STM.c - rts/Schedule.c - rts/Sparks.c - rts/StableName.c - rts/ThreadPaused.c - rts/Threads.c - rts/Trace.h - rts/include/rts/RtsToHsIface.h - rts/include/stg/MiscClosures.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - rts/posix/Timeout.c - rts/sm/Compact.c - rts/sm/GC.c - rts/sm/GCUtils.c - rts/sm/MBlock.c - rts/sm/NonMoving.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - rts/sm/Sweep.c - utils/check-exact/ExactPrint.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/6646c67ab3c35d6804e4930baabba1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6646c67ab3c35d6804e4930baabba1… 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/T27731] Simplify the cec_supress story
by Simon Peyton Jones (＠simonpj) 11 Sep '26

11 Sep '26

Simon Peyton Jones pushed to branch wip/T27731 at Glasgow Haskell Compiler / GHC Commits: 61ba8455 by Simon Peyton Jones at 2026-09-10T17:19:32+01:00 Simplify the cec_supress story In particular stop trying to predict if we will report a serious error in the future. Still needs some work on documentation. - - - - - 1 changed file: - compiler/GHC/Tc/Errors.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -256,21 +256,16 @@ report_unsolved type_errors expr_holes ; warn_redundant <- woptM Opt_WarnRedundantConstraints ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See (SLIE1) in - -- Note [cec_suppress: suppressing less-important error messages] - -- Suppress low-priority errors if there are insoluble errors - -- anywhere in the treee. See #15539 and c.f. setting ic_status - -- in GHC.Tc.Solver.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_expand_syns = exp_syns - , cec_binds = binds_var } + , cec_suppress = False + , cec_warn_redundant = warn_redundant + , cec_expand_syns = exp_syns + , cec_binds = binds_var } ; tc_lvl <- getTcLevel ; reportWanteds err_ctxt tc_lvl wanted @@ -689,7 +684,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- Don't suppress holes or concreteness errors unless we have scope errors ; reportHoles tidy_items ctxt_for_insols other_holes - ; reportNotConcreteErrs ctxt_for_insols not_conc_errs + ; reportNotConcreteErrs ctxt_for_insols not_conc_errs -- We only want to report multiplicity coercion errors for multiplicity -- constraints which are /solved/ with a non-reflexivity coercion. We @@ -699,27 +694,28 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs - -- Now the main batch of utterly-wrong things + -- Now the constraints that give serious errors -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 tidy_items - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed (ctxt1), or if the enclosing context - -- says to suppress AND there are local insolubles that are all suppressed. - -- See (SLIE3) in Note [cec_suppress: suppressing less-important error messages] - ; let insols = filter ei_insoluble tidy_items - all_insols_suppressed | null insols = False - | otherwise = all ei_suppress insols - ctxt2 = ctxt1 { cec_suppress = (cec_suppress ctxt && not all_insols_suppressed) - || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 items1 + ; (items1, no_serious_errs) + <- askNoErrs $ + tryReporters ctxt_for_insols serious_reporters tidy_items + + -- Now take account of the inherited cec_suppress, and augment it + -- to suppress further errors if we have found any serious errors locally + ; let suppress_for_rest = cec_suppress ctxt + || not no_out_of_scope + || not no_serious_errs + ctxt_for_rest = ctxt { cec_suppress = suppress_for_rest } + + -- Next, deal with the less-serious constraints + ; leftovers <- tryReporters ctxt_for_rest less_serious_reporters items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" $$ ppr leftovers) - ; mapBagM_ (reportImplic ctxt2) implics + ; mapBagM_ (reportImplic ctxt_for_rest) implics -- NB ctxt2: don't suppress inner insolubles if there's only a -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) @@ -745,59 +741,58 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics DE_Multiplicity mult_co loc -> (es1, es2, es3, (mult_co, loc):es4) - -- report1: ones that should *not* be suppressed by cec_suppress, - -- (i.e. by an insoluble somewhere else in the tree) - -- It's crucial that anything that is considered insoluble - -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise - -- we might suppress its error message, and proceed on past - -- type checking to get a Lint error later - report1 = [ -- We put implicit lifting errors first, because are solid errors - -- See "Implicit lifting" in GHC.Tc.Gen.Splice - -- Note [Lifecycle of an untyped splice, and PendingRnSplice] - ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) - - -- Next, solid equality errors - , given_eq_spec - , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", very_wrong, True, mkSkolReporter) - , ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr) - , ("skolem eq2", skolem_eq, True, mkSkolReporter) - - -- Next, custom type errors - -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint - -- - -- Put custom type errors /after/ solid equality errors. In #26255 we - -- had a custom error (T <= F alpha) which was suppressing a far more - -- informative (K Int ~ [K alpha]). That mismatch between K and [] is - -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence - -- perhaps be able to solve T <= F alpha, by reducing F Int. - -- - -- But put custom type errors /before/ "non-tv eq", because if we have - -- () ~ TypeError blah - -- we want to report it as a custom error, /not/ as a mis-match - -- between TypeError and ()! Also see the Assert example - -- in Note [Custom type errors in constraints] - , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - -- (Handles TypeError and Unsatisfiable) - - -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar - , ("non-tv eq", non_tv_eq, True, mkSkolReporter) - - -- The only remaining equalities are alpha ~ ty, - -- where alpha is untouchable; and representational equalities - -- Prefer homogeneous equalities over hetero, because the - -- former might be holding up the latter. - -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality - , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) - - , ("Insoluble fundeps", is_insoluble, True, mkGroupReporter mkDictErr) - ] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) - , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] + --serious_reporters: ones that should *not* be suppressed by cec_suppress, + -- (i.e. by an insoluble somewhere else in the tree) + serious_reporters + = [ -- We put implicit lifting errors first, because are solid errors + -- See "Implicit lifting" in GHC.Tc.Gen.Splice + -- Note [Lifecycle of an untyped splice, and PendingRnSplice] + ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) + + -- Next, solid equality errors + , given_eq_spec + , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) + , ("skolem eq1", very_wrong, True, mkSkolReporter) + , ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr) + , ("skolem eq2", skolem_eq, True, mkSkolReporter) + + -- Next, custom type errors + -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint + -- + -- Put custom type errors /after/ solid equality errors. In #26255 we + -- had a custom error (T <= F alpha) which was suppressing a far more + -- informative (K Int ~ [K alpha]). That mismatch between K and [] is + -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence + -- perhaps be able to solve T <= F alpha, by reducing F Int. + -- + -- But put custom type errors /before/ "non-tv eq", because if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! Also see the Assert example + -- in Note [Custom type errors in constraints] + , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) + + -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar + , ("non-tv eq", non_tv_eq, True, mkSkolReporter) + + -- The only remaining equalities are alpha ~ ty, + -- where alpha is untouchable; and representational equalities + -- Prefer homogeneous equalities over hetero, because the + -- former might be holding up the latter. + -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality + , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) + , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + + , ("Insoluble fundeps", is_insoluble, True, mkGroupReporter mkDictErr) + ] + + -- less_serious_reporters: we suppress these if have already + -- reported a serious error, higher in the tree + less_serious_reporters + = [ ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) + , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] -- rigid_nom_eq, rigid_nom_tv_eq, is_dict, is_equality, is_FRR, is_irred :: ErrorItem -> Pred -> Bool @@ -1310,14 +1305,16 @@ cmp_loc item1 item2 = get item1 `compare` get item2 reportGroup :: (NonEmpty ErrorItem -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt items - = do { err <- mk_err items + = do { traceTc "reportGroup" (ppr items) + ; err <- mk_err items ; traceTc "About to maybeReportErr" $ vcat [ text "Constraint:" <+> ppr items , text "cec_suppress =" <+> ppr (cec_suppress ctxt) , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt items err -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr items) + ; mapM_ (addSolverDeferredBinding err) items } -- Add deferred bindings for all -- Redundant if we are going to abort compilation, @@ -1431,39 +1428,36 @@ mkErrorTerm ct_loc ty ctxt msg supp hints ; return $ evDelayedError ty err_str } tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] - -> TcM (SolverReportErrCtxt, [ErrorItem]) + -> TcM [ErrorItem] -- Use the first reporter in the list whose predicate says True tryReporters ctxt reporters items = do { let (vis_items, invis_items) = partition (isVisibleOrigin . errorItemOrigin) items ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) - ; (ctxt', items') <- go ctxt reporters vis_items invis_items + ; items' <- go reporters vis_items invis_items ; traceTc "tryReporters }" (ppr items') - ; return (ctxt', items') } + ; return items' } where - go ctxt [] vis_items invis_items - = return (ctxt, vis_items ++ invis_items) + go [] vis_items invis_items + = return (vis_items ++ invis_items) - go ctxt (r : rs) vis_items invis_items + go (r : rs) vis_items invis_items -- Always look at *visible* Origins before invisible ones -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items - ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items - ; go ctxt'' rs vis_items' invis_items' } + = do { vis_items' <- tryReporter ctxt r vis_items + ; invis_items' <- tryReporter ctxt r invis_items + ; go rs vis_items' invis_items' } -- Carry on with the rest, because we must make -- deferred bindings for them if we have -fdefer-type-errors -- But suppress their error messages -tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) items = case nonEmpty yeses of - Nothing -> pure (ctxt, items) +tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM [ErrorItem] +tryReporter ctxt (str, keep_me, _, reporter) items = case nonEmpty yeses of + Nothing -> return items Just yeses -> do { traceTc "tryReporter{ " (text str <+> ppr yeses) - ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after - -- See (SLIE2) in Note [cec_suppress: suppressing less-important error messages] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after <+> ppr (cec_suppress ctxt')) - ; return (ctxt', nos) } + ; reporter ctxt yeses + ; traceTc "tryReporter end }" empty + ; return nos } where (yeses, nos) = partition keep items keep item = keep_me item (classifyPredType (errorItemPred item)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61ba8455d7c15d1f098d4d7b24d7180… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61ba8455d7c15d1f098d4d7b24d7180… 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/T27724] Complete the noinline story
by Simon Peyton Jones (＠simonpj) 11 Sep '26

11 Sep '26

Simon Peyton Jones pushed to branch wip/T27724 at Glasgow Haskell Compiler / GHC Commits: 5b405cd7 by Simon Peyton Jones at 2026-09-10T17:08:46+01:00 Complete the noinline story - - - - - 12 changed files: - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore.hs - compiler/GHC/Tc/Instance/Class.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - testsuite/tests/corelint/LintEtaExpand.hs - utils/genprimopcode/Main.hs Changes: ===================================== compiler/GHC/Builtin/WiredIn/Ids.hs ===================================== @@ -18,13 +18,16 @@ module GHC.Builtin.WiredIn.Ids ( wiredInIds, ghcPrimIds, realWorldPrimId, voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, - coercionTokenId, coerceId, - proxyHashId, + nullAddrId, seqId, lazyId, lazyIdKey, proxyHashId, + coercionTokenId, coerceId, coerceName, nospecId, nospecIdName, - noinlineId, noinlineIdName, - noinlineConstraintId, noinlineConstraintIdName, - coerceName, leftSectionName, rightSectionName, + + getNoinlineId, isNoinlineId, + noinlineId, noinlineIdName, + noinlineConstraintId, noinlineConstraintIdName, + + leftSectionName, rightSectionName, + pcRepPolyId, unboxedUnitExpr, @@ -54,11 +57,14 @@ import GHC.Types.Name.Env import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma -import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName) +import GHC.Types.Var (VarBndr(Bndr), invisArgConstraintLike, tyVarName) +import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType +import GHC.Utils.Panic +import GHC.Utils.Outputable import GHC.Data.FastString @@ -92,7 +98,7 @@ that module's interface file; instead, the full definition is right here. Note [ghcPrimIds (aka pseudoops)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ghcPrimIds * Are exported from GHC.Prim (see ghcPrimExports, used in ghcPrimInterface) @@ -239,15 +245,15 @@ seqId = pcRepPolyId seqName ty concs info -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b ty = mkInfForAllTy runtimeRep2TyVar - $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] - $ mkVisFunTyMany alphaTy (mkVisFunTyMany openBetaTy openBetaTy) + $ mkSpecForAllTys [alphaTyVar, rrPolyTyVar2] + $ mkVisFunTyMany alphaTy (mkVisFunTyMany rrPolyTy2 rrPolyTy2) - [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] + [x,y] = mkTemplateLocals [rrPolyTy1, rrPolyTy2] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, rrPolyTyVar2, x, y]) $ + Case (Var x) x rrPolyTy2 [Alt DEFAULT [] (Var y)] concs = mkRepPolyIdConcreteTyVars - [ ((openBetaTy, mkArgPos 2 Top), runtimeRep2TyVar)] + [ ((rrPolyTy2, mkArgPos 2 Top), runtimeRep2TyVar)] arity = 2 @@ -271,15 +277,27 @@ noinlineId = pcMiscPrelId noinlineIdName ty info info = noCafIdInfo -- noinline :: forall r (a :: TYPE r). a -> a ty = mkInfForAllTy runtimeRep1TyVar $ - mkSpecForAllTys [openAlphaTyVar] $ - mkVisFunTyMany openAlphaTy openAlphaTy + mkSpecForAllTys [rrPolyTyVar1] $ + mkVisFunTyMany rrPolyTy1 rrPolyTy1 noinlineConstraintId :: Id -- See Note [noinlineId magic] noinlineConstraintId = pcMiscPrelId noinlineConstraintIdName ty info where info = noCafIdInfo - ty = mkSpecForAllTys [alphaConstraintTyVar] $ - mkFunTy visArgConstraintLike ManyTy alphaTy alphaConstraintTy + ty = mkInfForAllTy runtimeRep1TyVar $ + mkSpecForAllTys [rrPolyConstraintVar1] $ + mkFunTy invisArgConstraintLike ManyTy rrPolyConstraintTy1 rrPolyConstraintTy1 + +isNoinlineId :: Id -> Bool +isNoinlineId fn = key == noinlineIdKey || key == noinlineConstraintIdKey + where + key = getUnique fn + +getNoinlineId :: Type -> (Id, RuntimeRepType) +getNoinlineId ty = case sORTKind_maybe (typeKind ty) of + Just (TypeLike, rep) -> (noinlineId, rep) + Just (ConstraintLike, rep) -> (noinlineConstraintId, rep) + Nothing -> pprPanic "getNoinlineId" (ppr ty) ------------------------------------------------ nospecId :: Id -- See Note [nospecId magic] @@ -296,19 +314,19 @@ oneShotId = pcRepPolyId oneShotName ty concs info `setArityInfo` arity -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b) ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ - mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ + mkSpecForAllTys [ rrPolyTyVar1, rrPolyTyVar2 ] $ mkVisFunTyMany fun_ty fun_ty - fun_ty = mkVisFunTyMany openAlphaTy openBetaTy - [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + fun_ty = mkVisFunTyMany rrPolyTy1 rrPolyTy2 + [body, x] = mkTemplateLocals [fun_ty, rrPolyTy1] x' = setOneShotLambda x -- Here is the magic bit! rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar + , rrPolyTyVar1, rrPolyTyVar2 , body, x'] $ Var body `App` Var x' arity = 2 concs = mkRepPolyIdConcreteTyVars - [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + [((rrPolyTy1, mkArgPos 2 Top), runtimeRep1TyVar)] ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] @@ -340,20 +358,20 @@ leftSectionId = pcRepPolyId leftSectionName ty concs info `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ - mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ + mkSpecForAllTys [rrPolyTyVar1, rrPolyTyVar2] $ exprType body - [f,x] = mkTemplateLocals [mkVisFunTy mult openAlphaTy openBetaTy, openAlphaTy] + [f,x] = mkTemplateLocals [mkVisFunTy mult rrPolyTy1 rrPolyTy2, rrPolyTy1] mult = mkTyVarTy multiplicityTyVar1 :: Mult xmult = setIdMult x mult rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1 - , openAlphaTyVar, openBetaTyVar ] body + , rrPolyTyVar1, rrPolyTyVar2 ] body body = mkLams [f,xmult] $ App (Var f) (Var xmult) arity = 2 concs = mkRepPolyIdConcreteTyVars - [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + [((rrPolyTy1, mkArgPos 2 Top), runtimeRep1TyVar)] -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax] @@ -369,26 +387,26 @@ rightSectionId = pcRepPolyId rightSectionName ty concs info `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar , multiplicityTyVar1, multiplicityTyVar2 ] $ - mkSpecForAllTys [openAlphaTyVar, openBetaTyVar, openGammaTyVar ] $ + mkSpecForAllTys [rrPolyTyVar1, rrPolyTyVar2, rrPolyTyVar3] $ exprType body mult1 = mkTyVarTy multiplicityTyVar1 mult2 = mkTyVarTy multiplicityTyVar2 - [f,x,y] = mkTemplateLocals [ mkScaledFunTys [ Scaled mult1 openAlphaTy - , Scaled mult2 openBetaTy ] openGammaTy - , openAlphaTy, openBetaTy ] + [f,x,y] = mkTemplateLocals [ mkScaledFunTys [ Scaled mult1 rrPolyTy1 + , Scaled mult2 rrPolyTy2 ] rrPolyTy3 + , rrPolyTy1, rrPolyTy2 ] xmult = setIdMult x mult1 ymult = setIdMult y mult2 rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar , multiplicityTyVar1, multiplicityTyVar2 - , openAlphaTyVar, openBetaTyVar, openGammaTyVar ] body + , rrPolyTyVar1, rrPolyTyVar2, rrPolyTyVar3 ] body body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult] arity = 3 concs = mkRepPolyIdConcreteTyVars - [ ((openAlphaTy, mkArgPos 3 Top), runtimeRep1TyVar) - , ((openBetaTy , mkArgPos 2 Top), runtimeRep2TyVar)] + [ ((rrPolyTy1, mkArgPos 3 Top), runtimeRep1TyVar) + , ((rrPolyTy2, mkArgPos 2 Top), runtimeRep2TyVar)] -------------------------------------------------------------------------------- @@ -521,55 +539,55 @@ Implementing 'lazy' is a bit tricky: Note [noinlineId magic] ~~~~~~~~~~~~~~~~~~~~~~~ -'noinline' is used to make sure that a function f is never inlined, -e.g., as in 'noinline f x'. We won't inline f because we never inline -lone variables (see Note [Lone variables] in GHC.Core.Unfold +'noinline' is used to make sure that a function f is never inlined, e.g + noinline f x + noinline (f x) +Both of these will work. Here are the moving parts: -You might think that we could implement noinline like this: - {-# NOINLINE #-} - noinline :: forall a. a -> a - noinline x = x +* `noinline` is magic Id (see Note [magicIds]), whose wired-in behaviour is + defined in this module, GHC.Builtin.WiredIn.Ids. -But actually we give 'noinline' a wired-in name for three distinct reasons: +* In the Simplifier, see the `isNoInlineId` case of `simplOutId`. + When we encounter noinline (f e1 e2) e3 e4: + * We switch off inlining before simplifying `f` (#18995) + * We slide `e3` and `e4` under the `noinline` to give + noinline (f e1 e2 e3 e4) + See wrinkle (NOI1) -1. We don't want to leave a (useless) call to noinline in the final program, - to be executed at runtime. So we have a little bit of magic to - optimize away 'noinline' after we are done running the simplifier. - This is done in GHC.CoreToStg.Prep.cpeApp. - -2. 'noinline' sometimes gets inserted automatically when we serialize an - expression to the interface format, in GHC.CoreToIface.toIfaceVar. - See Note [Inlining and hs-boot files] in GHC.CoreToIface - -3. Given foo :: Eq a => [a] -> Bool, the expression - noinline foo x xs - where x::Int, will naturally desugar to - noinline @Int (foo @Int dEqInt) x xs - But now it's entirely possible that (foo @Int dEqInt) will inline foo, - since 'foo' is no longer a lone variable -- see #18995 - - Solution: in the desugarer, rewrite - noinline (f x y) ==> noinline f x y - This is done in the `noinlineId` case of `GHC.HsToCore.Expr.ds_app_var` - This is only needed for noinlineId, not noInlineConstraintId (wrinkle - (W1) below), because the latter never shows up in user code. +* In GHC.CoreToStg.Prep.cpe_app, we discard the `noinline`, so that + there is no runtime overhead. Wrinkles -(W1) Sometimes case (2) above needs to apply `noinline` to a type of kind +(NOI1) It's very important to have + noinline (f e1 e2) -- `f` visibly applied + and NOT + noinline f e1 e2 -- `f` is not applied + Because we want + * Strictness (#18396, #23911, #16588) + * Type-class specialisation (#27724) + * Rewrite rules + all to work, and they won't if `f` isn't applied to anything + +(NOI2) `noinline` needs to apply to unboxed types, so that + noinline (f x y) + works even if `f` happens to return Int#. So + noinline :: forall (r::RuntimeRep) (a::TYPE r). a -> a + +(NOI3) Very trickily, 'noinline' sometimes gets inserted automatically when we + serialize an expression to the interface format, in `GHC.CoreToIface.toIfaceVar`. + See Note [Inlining and hs-boot files] in GHC.CoreToIface + +(NOI4) Sometimes case (NOI3) needs to apply `noinline` to a type of kind Constraint; e.g. noinline @(Eq Int) $dfEqInt - We don't have type-or-kind polymorphism, so we simply have two `inline` - Ids, namely `noinlineId` and `noinlineConstraintId`. - -(W2) Note that noinline as currently implemented can hide some simplifications - since it hides strictness from the demand analyser. Specifically, the - demand analyser will treat 'noinline f x' as lazy in 'x', even if the - demand signature of 'f' specifies that it is strict in its argument. We - considered fixing this this by adding a special case to the demand - analyser to address #16588. However, the special case seemed like a large - and expensive hammer to address a rare case and consequently we rather - opted to use a more minimal solution. + We don't have type-or-constraint polymorphism, so we simply have two + `inline` Ids, namely `noinlineId` and `noinlineConstraintId`: + + noinline :: forall (r::RuntimeRep) (a::TYPE r). a -> a + noinlineConstraint :: forall (r::RuntimeRep) (a::CONSTRAINT r). a => a + + Tiresome but simple. Note [nospecId magic] ~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Builtin/WiredIn/Prim.hs ===================================== @@ -32,10 +32,13 @@ module GHC.Builtin.WiredIn.Prim( alphaConstraintTyVar, alphaConstraintTy, - openAlphaTyVar, openBetaTyVar, openGammaTyVar, - openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, - openAlphaTy, openBetaTy, openGammaTy, + -- Runtime-rep-polymorphic tyvars, of kind (TYPE rr) + rrPolyTyVar1, rrPolyTyVar2, rrPolyTyVar3, + rrPolyTy1, rrPolyTy2, rrPolyTy3, + rrPolyTyVarSpec1, rrPolyTyVarSpec2, rrPolyTyVarSpec3, + rrPolyConstraintVar1, rrPolyConstraintTy1, + -- Levity-polymorphic tyvars levPolyAlphaTyVar, levPolyBetaTyVar, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, levPolyAlphaTy, levPolyBetaTy, @@ -503,24 +506,29 @@ runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar -openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar --- alpha :: TYPE r1 --- beta :: TYPE r2 --- gamma :: TYPE r3 -[openAlphaTyVar,openBetaTyVar,openGammaTyVar] + +rrPolyTyVar1, rrPolyTyVar2, rrPolyTyVar3, rrPolyConstraintVar1 :: TyVar +-- rrPolyTyVar1 :: TYPE r1 +-- rrPolyTyVar2 :: TYPE r2 +-- rrPolyTyVar2 :: TYPE r3 +-- rrPolyConstraintVar1 :: CONSTRAINT r1 +-- All have distinct uniques +[ rrPolyTyVar1, rrPolyTyVar2, rrPolyTyVar3, rrPolyConstraintVar1 ] = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty , mk_TYPE_app runtimeRep2Ty - , mk_TYPE_app runtimeRep3Ty] - -openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder -openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar -openBetaTyVarSpec = mkTyVarBinder Specified openBetaTyVar -openGammaTyVarSpec = mkTyVarBinder Specified openGammaTyVar - -openAlphaTy, openBetaTy, openGammaTy :: Type -openAlphaTy = mkTyVarTy openAlphaTyVar -openBetaTy = mkTyVarTy openBetaTyVar -openGammaTy = mkTyVarTy openGammaTyVar + , mk_TYPE_app runtimeRep3Ty + , mk_CONSTRAINT_app runtimeRep1Ty ] + +rrPolyTyVarSpec1, rrPolyTyVarSpec2, rrPolyTyVarSpec3 :: TyVarBinder +rrPolyTyVarSpec1 = mkTyVarBinder Specified rrPolyTyVar1 +rrPolyTyVarSpec2 = mkTyVarBinder Specified rrPolyTyVar2 +rrPolyTyVarSpec3 = mkTyVarBinder Specified rrPolyTyVar3 + +rrPolyTy1, rrPolyTy2, rrPolyTy3, rrPolyConstraintTy1 :: Type +rrPolyTy1 = mkTyVarTy rrPolyTyVar1 +rrPolyTy2 = mkTyVarTy rrPolyTyVar2 +rrPolyTy3 = mkTyVarTy rrPolyTyVar3 +rrPolyConstraintTy1 = mkTyVarTy rrPolyConstraintVar1 levity1TyVar, levity2TyVar :: TyVar (levity2TyVar : levity1TyVar : _) -- NB: levity2TyVar before levity1TyVar ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,8 +60,8 @@ import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.WiredIn.Prim( realWorldStatePrimTy ) -import GHC.Builtin.KnownKeys( runRWKey, seqHashKey, noinlineIdKey ) -import GHC.Builtin.WiredIn.Ids( seqId ) +import GHC.Builtin.KnownKeys( runRWKey, seqHashKey ) +import GHC.Builtin.WiredIn.Ids( seqId, getNoinlineId, isNoinlineId ) import qualified GHC.Data.List.Infinite as Inf import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) @@ -2369,8 +2369,8 @@ simplOutId env fun cont call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] ; rebuild_go env call' outer_cont } -simplOutId env inline_fun cont - | inline_fun `hasKey` noinlineIdKey +simplOutId env noinline_fun cont + | isNoinlineId noinline_fun , ApplyToTy { sc_cont = cont1 } <- cont , ApplyToTy { sc_cont = cont2 } <- cont1 , ApplyToVal { sc_cont = cont3, sc_arg = the_call, sc_cast = arg_mco @@ -2386,10 +2386,12 @@ simplOutId env inline_fun cont ; let call_env = updMode updModeForNoInline $ arg_se `setInScopeFromE` env ; (floats1, call') <- simplExprF call_env inner_fun call_cont - ; let new_call_ty = contHoleType rest_cont - noinline_expr = Var inline_fun `App` Type (getRuntimeRep new_call_ty) - `App` Type new_call_ty - `App` mkCastMCo call' arg_mco + ; let new_call_ty = contHoleType rest_cont + (new_noinline_fun, rep) = getNoinlineId new_call_ty + noinline_expr = Var new_noinline_fun + `App` Type rep + `App` Type new_call_ty + `App` mkCastMCo call' arg_mco ; (floats2, res) <- rebuild env noinline_expr rest_cont ; return (floats2 `addFloats` floats1 , res) } ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -114,7 +114,8 @@ type KindOrType = Type -- See Note [Arguments to type constructors] -- | The key type representing kinds in the compiler. type Kind = Type --- | Type synonym used for types of kind RuntimeRep. +-- | Type synonym used for Types of kind RuntimeRep. +-- E.g. The type IntRep :: RuntimeRep type RuntimeRepType = Type -- | Type synonym used for types of kind Levity. ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -2686,7 +2686,7 @@ typeKind ty@(ForAllTy {}) --------------------------------------------- -sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type) +sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, RuntimeRepType) -- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep) -- and if so returns which, and the runtime rep -- ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -63,7 +63,7 @@ import GHC.Core.TyCo.Tidy import GHC.Builtin.WiredIn.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.WiredIn.Types ( heqTyCon ) -import GHC.Builtin.WiredIn.Ids ( noinlineIdName ) +import GHC.Builtin.WiredIn.Ids ( getNoinlineId ) import GHC.Iface.Syntax import GHC.Data.FastString @@ -658,9 +658,9 @@ toIfaceVar :: Id -> IfaceExpr toIfaceVar v | isBootUnfolding (idUnfolding v) = -- See Note [Inlining and hs-boot files] - IfaceExt noinlineIdName `IfaceApp` - IfaceType (toIfaceType rep) `IfaceApp` - IfaceType (toIfaceType ty) `IfaceApp` + IfaceExt (idName noinline_id) `IfaceApp` + IfaceType (toIfaceType rep) `IfaceApp` + IfaceType (toIfaceType ty) `IfaceApp` IfaceExt name -- Don't use mkIfaceApps, or infinite loop | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) @@ -671,7 +671,7 @@ toIfaceVar v where name = idName v ty = idType v - rep = getRuntimeRep ty + (noinline_id, rep) = getNoinlineId ty --------------------- toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo @@ -750,7 +750,7 @@ But how do we arrange for this to happen? There are two ingredients: 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), for every variable reference we see if we are referring to an 'Id' that came from an hs-boot file. If so, we add a `noinline` - to the reference. See Note [noinlineId magic] + to the reference. See Note [noinlineId magic] esp (NOI3) in GHC.Types.Id.Make 2. But how do we know if a reference came from an hs-boot file ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Prim -import GHC.Builtin.WiredIn.Ids ( realWorldPrimId ) +import GHC.Builtin.WiredIn.Ids ( realWorldPrimId, isNoinlineId ) import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -1274,7 +1274,7 @@ eliminateMagicCall f (AIApp Type{} : AIApp arg : args) -- See Note [nospecId magic] in GHC.Types.Id.Make eliminateMagicCall f (AIApp Type{} : AIApp Type{} : AIApp arg : args) - | f `hasKey` noinlineIdKey = Just (arg,args) + | isNoinlineId f = Just (arg,args) -- Replace (noinline a) with a -- See Note [noinlineId magic] in GHC.Types.Id.Make ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -706,8 +706,10 @@ patchMagicDefn orig_pair@(orig_id, orig_rhs) = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs -- Patching should not change the Name or the type of the Id - ; massert (getUnique magic_id == getUnique orig_id) - ; massert (varType magic_id `eqType` varType orig_id) + ; massertPpr (getUnique magic_id == getUnique orig_id) (ppr orig_id) + ; massertPpr (varType magic_id `eqType` varType orig_id) $ + vcat [ text "orig_id:" <+> ppr orig_id <+> dcolon <+> ppr (varType orig_id) + , text "magic_id:" <+> ppr magic_id <+> dcolon <+> ppr (varType magic_id) ] ; return magic_pair } | otherwise @@ -752,7 +754,7 @@ mkUnsafeCoercePrimPair _old_id old_expr ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar + , rrPolyTyVar1, rrPolyTyVar2 , x ] $ mkSingleAltCase scrut1 (mkWildValBinder ManyTy scrut1_ty) @@ -765,7 +767,7 @@ mkUnsafeCoercePrimPair _old_id old_expr Var x `mkCast` x_co [x, rr_cv, ab_cv] = mkTemplateLocals - [ openAlphaTy -- x :: a + [ rrPolyTy1 -- x :: a , rr_cv_ty -- rr_cv :: r1 ~# r2 , ab_cv_ty -- ab_cv :: (alpha |> alpha_co ~# beta) ] @@ -783,15 +785,15 @@ mkUnsafeCoercePrimPair _old_id old_expr runtimeRep1Ty runtimeRep2Ty (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty) - (openAlphaTy `mkCastTy` alpha_co) - openBetaTy + (rrPolyTy1 `mkCastTy` alpha_co) + rrPolyTy2 -- alpha_co :: TYPE r1 ~# TYPE r2 -- alpha_co = TYPE rr_cv alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv] -- x_co :: alpha ~R# beta - x_co = mkGReflMCo Representational openAlphaTy alpha_co `mkTransCo` + x_co = mkGReflMCo Representational rrPolyTy1 alpha_co `mkTransCo` mkSubCo (mkCoVarCo ab_cv) @@ -800,13 +802,13 @@ mkUnsafeCoercePrimPair _old_id old_expr `setArityInfo` arity ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] $ - mkVisFunTyMany openAlphaTy openBetaTy + , rrPolyTyVar1, rrPolyTyVar2 ] $ + mkVisFunTyMany rrPolyTy1 rrPolyTy2 arity = 1 concs = mkRepPolyIdConcreteTyVars - [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)] + [((rrPolyTy1, mkArgPos 1 Top), runtimeRep1TyVar)] unsafeCoercePrimName id = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -443,7 +443,7 @@ matchWithDict [cls_ty, mty] , Just (cls, dict_dc) <- isUnaryClassTyCon_maybe dict_tc , [inst_meth_ty] <- dataConInstArgTys dict_dc dict_args = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty - ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty openAlphaTy) + ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty rrPolyTy1) ; wd_cls <- tcLookupKnownKeyClass withDictClassKey -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of @@ -452,7 +452,7 @@ matchWithDict [cls_ty, mty] -- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> -- k (MkC tys (sv |> sub co2)) ; let evWithDict ev_expr - = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ + = mkCoreLams [ runtimeRep1TyVar, rrPolyTyVar1, sv, k ] $ Var k `App` (evUnaryDictAppE cls dict_args meth_arg) where meth_arg = Var sv `mkCast` mkSubCo (evExprCoercion ev_expr) ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -62,9 +62,14 @@ inline x = x -- | The call @noinline f@ arranges that @f@ will not be inlined. -- It is removed during CorePrep so that its use imposes no overhead -- (besides the fact that it blocks inlining.) -noinline :: a -> a -{-# NOINLINE noinline #-} -- noinline is inlined manually in CorePrep -noinline x = x +noinline :: forall (r :: RuntimeRep) (a :: TYPE r). + a -> a +{-# NOINLINE noinline #-} +-- See Note [noinlineId magic] in GHC.Builtin.WiredIn.Ids +noinline = noinline -- Never called, eliminated in CorePrep + -- We can't conveniently call `error` here because + -- GHC.Internal.Err depends on GHC.Internal.Magic.noinline! + -- Hence this silly loop. -- | The 'lazy' function restrains strictness analysis a little. The -- call @lazy e@ means the same as @e@, but 'lazy' has a magical ===================================== testsuite/tests/corelint/LintEtaExpand.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Builtin.PrimOps.Ids ( primOpId ) import GHC.Builtin.WiredIn.Prim ( runtimeRep1Ty, runtimeRep1TyVar - , openAlphaTy, openAlphaTyVar + , rrPolyTyVar1, rrPolyTy1 ) import GHC.Core @@ -79,7 +79,7 @@ test_exprs = [ Type liftedDataConTy , Type liftedRepTy , Type intTy - , Type $ mkVisFunTyMany openAlphaTy openAlphaTy + , Type $ mkVisFunTyMany rrPolyTy1 rrPolyTy1 ] , ("raise# OK 2", ) $ -- raise# @Lifted @r @@ -107,7 +107,7 @@ test_exprs = -- These will be considered in-scope by the Core Lint checks. in_scope :: [ Id ] -in_scope = [ runtimeRep1TyVar, openAlphaTyVar ] +in_scope = [ runtimeRep1TyVar, rrPolyTyVar1 ] main :: IO () main = do ===================================== utils/genprimopcode/Main.hs ===================================== @@ -751,15 +751,16 @@ ppTyVar "a" = nonDepTyVarBinder "alphaTyVarSpec" ppTyVar "b" = nonDepTyVarBinder "betaTyVarSpec" ppTyVar "c" = nonDepTyVarBinder "gammaTyVarSpec" ppTyVar "s" = nonDepTyVarBinder "deltaTyVarSpec" + -- See Note [Levity and representation polymorphic primops] in primops.txt.pp ppTyVar "a_reppoly" = PrimOpTyVarBinder { inferredTyVarBinders = ["runtimeRep1TyVarInf"] - , primOpTyVarBinder = "openAlphaTyVarSpec" } + , primOpTyVarBinder = "rrPolyTyVarSpec1" } ppTyVar "b_reppoly" = PrimOpTyVarBinder { inferredTyVarBinders = ["runtimeRep2TyVarInf"] - , primOpTyVarBinder = "openBetaTyVarSpec" } + , primOpTyVarBinder = "rrPolyTyVarSpec2" } ppTyVar "a_levpoly" = PrimOpTyVarBinder { inferredTyVarBinders = ["levity1TyVarInf"] @@ -802,8 +803,8 @@ ppType (TyVar "b") = "betaTy" ppType (TyVar "c") = "gammaTy" ppType (TyVar "s") = "deltaTy" -- See Note [Levity and representation polymorphic primops] in primops.txt.pp -ppType (TyVar "a_reppoly") = "openAlphaTy" -ppType (TyVar "b_reppoly") = "openBetaTy" +ppType (TyVar "a_reppoly") = "rrPolyTy1" +ppType (TyVar "b_reppoly") = "rrPolyTy2" ppType (TyVar "a_levpoly") = "levPolyAlphaTy" ppType (TyVar "b_levpoly") = "levPolyBetaTy" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b405cd7ed126c62a9568e3682e93a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b405cd7ed126c62a9568e3682e93a4… 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/full-eventlog-live] 2 commits: Support for `eventlog-socket`
by Wen Kokke (＠wenkokke) 10 Sep '26

10 Sep '26

Wen Kokke pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC Commits: 15866323 by Matthew Pickering at 2026-09-10T14:42:07+01:00 Support for `eventlog-socket` This adds the +eventlog-socket feature flag. If set, GHC is instrumented with Eventlog Socket. - - - - - 41ed3d90 by fendor at 2026-09-10T14:58:26+01:00 Support for `ghc-stack-profiler` This adds the +ghc-stack-profiler feature flag. If set, GHC is instrumented with GHC Stack Profiler. - - - - - 11 changed files: - .gitmodules - + eventlog-socket - + ghc-stack-profiler - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + libraries/async - + libraries/hashable - + libraries/unordered-containers Changes: ===================================== .gitmodules ===================================== @@ -122,3 +122,18 @@ [submodule "libraries/libffi-clib"] path = libraries/libffi-clib url = https://gitlab.haskell.org/ghc/libffi-clib.git +[submodule "eventlog-socket"] + path = eventlog-socket + url = https://github.com/well-typed/eventlog-socket.git +[submodule "ghc-stack-profiler"] + path = ghc-stack-profiler + url = https://github.com/well-typed/ghc-stack-profiler +[submodule "libraries/async"] + path = libraries/async + url = https://github.com/fendor/async.git +[submodule "libraries/unordered-containers"] + path = libraries/unordered-containers + url = https://github.com/fendor/unordered-containers.git +[submodule "libraries/hashable"] + path = libraries/hashable + url = https://github.com/fendor/hashable ===================================== eventlog-socket ===================================== @@ -0,0 +1 @@ +Subproject commit 57ca65170bf6d264a284a047f3cb350d498fc256 ===================================== ghc-stack-profiler ===================================== @@ -0,0 +1 @@ +Subproject commit 389d886a1494cd019ee93c72c8f19cf7f9dc1664 ===================================== ghc/Main.hs ===================================== @@ -93,6 +93,28 @@ import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(EVENTLOG_SOCKET) +import qualified GHC.Eventlog.Socket +#endif + +#if defined(GHC_STACK_PROFILER) +import qualified GHC.Stack.Profiler +#endif + +startEventlogSocketFromEnv :: IO () +#if defined(EVENTLOG_SOCKET) +startEventlogSocketFromEnv = GHC.Eventlog.Socket.startFromEnv +#else +startEventlogSocketFromEnv = pure () +#endif + +startGhcStackProfilerFromEnv :: IO () +#if defined(GHC_STACK_PROFILER) +startGhcStackProfilerFromEnv = void GHC.Stack.Profiler.startProfilerFromEnv +#else +startGhcStackProfilerFromEnv = pure () +#endif + ----------------------------------------------------------------------------- -- ToDo: @@ -107,6 +129,9 @@ import qualified Data.List.NonEmpty as NE main :: IO () main = do + startEventlogSocketFromEnv + startGhcStackProfilerFromEnv + hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,11 +27,21 @@ Flag interpreter Default: False Manual: True +Flag eventlog-socket + Description: Build with support for eventlog-socket + Default: False + Manual: True + Flag threaded Description: Link the ghc executable against the threaded RTS Default: True Manual: True +Flag ghc-stack-profiler + Description: Build with support for ghc-stack-profiler + Default: False + Manual: True + Executable ghc Default-Language: GHC2024 @@ -93,6 +103,14 @@ Executable ghc if flag(threaded) ghc-options: -threaded + if flag(eventlog-socket) + build-depends: eventlog-socket + CPP-OPTIONS: -DEVENTLOG_SOCKET + + if flag(ghc-stack-profiler) + build-depends: ghc-stack-profiler + CPP-OPTIONS: -DGHC_STACK_PROFILER + Other-Extensions: CPP NondecreasingIndentation ===================================== hadrian/src/Packages.hs ===================================== @@ -12,7 +12,9 @@ module Packages ( runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, timeout, transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, + eventlogSocket, eventlogSocketControl, ghcPackages, isGhcPackage, + async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programBasename, programName, nonHsMainPackage, programPath, timeoutPath, @@ -41,8 +43,11 @@ ghcPackages = , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell, thLift, thQuasiquoter , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout + , eventlogSocketControl, eventlogSocket , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -58,7 +63,8 @@ array, base, binary, bytestring, cabalSyntax, cabal, changelogD, checkPpr, check osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, transformers, unlit, unix, win32, xhtml, timeout, - lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, + eventlogSocket, eventlogSocketControl :: Package array = lib "array" base = lib "base" @@ -134,6 +140,13 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket" +eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control" +async = lib "async" +hashable = lib "hashable" +unorderedContainers = lib "unordered-containers" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -110,6 +110,8 @@ stage0Packages = do , thQuasiquoter -- new library not yet present for boot compilers , unlit , xhtml -- new version is not backwards compat with latest + , eventlogSocket + , eventlogSocketControl , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version -- bundled with GHC 9.6 is too old for `semaphore-compat`. @@ -190,6 +192,11 @@ stagedPackages stage = do , hpcBin , if winTarget then win32 else unix , runGhc + , ghc_stack_profiler + , ghc_stack_profiler_core + , async + , hashable + , unorderedContainers ] , when (winTarget && not cross) [ -- See Note [Hadrian's ghci-wrapper package] ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -105,6 +105,22 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_stack_profiler ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + -- Add support for eventlog-socket commands + , arg "+control" + ] + ] + + , package eventlogSocket ? mconcat + [ builder (Cabal Flags) ? mconcat + [ + -- Add support for eventlog-socket commands + arg "+control" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat @@ -114,6 +130,8 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ andM [expr (ghcWithInterpreter stage), orM [expr (notM cross), stage1]] `cabalFlag` "interpreter" , andM [expr (ghcWithInterpreter stage), notM (expr cross)] `cabalFlag` "internal-interpreter" + , notStage0 `cabalFlag` "eventlog-socket" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. ===================================== libraries/async ===================================== @@ -0,0 +1 @@ +Subproject commit 474fc7f612b74e73e24e91474fa75af18eede7b7 ===================================== libraries/hashable ===================================== @@ -0,0 +1 @@ +Subproject commit d56d62eb2a9ff4376e7119d925ececa60959d9ec ===================================== libraries/unordered-containers ===================================== @@ -0,0 +1 @@ +Subproject commit 368ea40488bf3c644e9c36d996302029fb0fc227 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57a6a8fab1cb42f9e4c2fd98883ec1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57a6a8fab1cb42f9e4c2fd98883ec1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

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

10 Sep '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 84da245c by mangoiv at 2026-09-10T17:01:58+02:00 fixup! ci: build and test stage - - - - - 1 changed file: - .gitlab/generate-ci/gen_ci.hs Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1140,8 +1140,8 @@ instance ToJSON a => ToJSON (JobGroup a) where , "r" .= r ] instance ToJSON a => ToJSON (BuildAndTestJob a) where - toJSON MkBuildAndTestJob {buildJob, testJobs} = - object [ "build" .= buildJob, "test" .= testJobs ] + -- the test job is not relevant for the job metadata output + toJSON MkBuildAndTestJob {buildJob} = toJSON buildJob -- | Construct a 'JobGroup' which consists of a validate, nightly and release build with -- a specific config. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84da245c9127db368182752b17e6f8a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84da245c9127db368182752b17e6f8a… 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