Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC
Commits:
60315570 by Teo Camarasu at 2026-06-19T10:01:07+01:00
Make Q abstract
This patch aims to clearly demarcate the internal and external interfaces
of Q.
In the past the `Quasi` typeclass was both part of the external,
public-facing interface, and was used to give the implementation of `Q`.
Now we separate out these two distinct roles. `Quasi` continues to exist
in the public interface, but we introduce a new `MetaHandlers` type,
which is equivalent to `Dict Quasi`.
`Q a` is now defined to be `MetaHandlers -> IO a`, and, crucially,
the constructor and the new `MetaHandlers` type are not exposed from the
public interface.
This gives us the ability to vary the interface on the GHC side without
forcing a breaking change on the `template-haskell` side.
Similarly `template-haskell` has more freedom to change the `Quasi`
typeclass without needing any changes in `lib:ghc`.
Implements https://github.com/ghc-proposals/ghc-proposals/pull/700
Resolves #27341
- - - - -
9 changed files:
- + changelog.d/AbstractQ
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
changelog.d/AbstractQ
=====================================
@@ -0,0 +1,9 @@
+section: template-haskell
+synopsis: Hide the implementation of Q
+description: The constructor of Q is now hidden.
+ This is done to improve the stability of ``template-haskell``.
+ To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``.
+ The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API.
+ See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details.
+mrs: !15696
+issues: #27341
=====================================
compiler/GHC/Data/IOEnv.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Data.IOEnv (
IOEnvFailure(..),
-- Getting at the environment
- getEnv, setEnv, updEnv, updEnvIO,
+ getEnv, setEnv, updEnv, updEnvIO, withRunInIO,
runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
tryM, tryAllM, tryMostM, fixM,
@@ -258,3 +258,12 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a
{-# INLINE updEnvIO #-}
updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+
+-- | 'withRunInIO' specialised to `IOEnv`.
+-- See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unl… for an explanation.
+withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
+withRunInIO k = IOEnv $ \env ->
+ let
+ unlift :: forall a. IOEnv env a -> IO a
+ unlift (IOEnv m) = m env
+ in k unlift
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
runAnnotation, getUntypedSpliceBody,
- runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+ runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM,
tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH, runTopSplice
@@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
import qualified GHC.Boot.TH.Monad as TH
+import GHC.Boot.TH.Monad (MetaHandlers(..))
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do
************************************************************************
-}
-runQuasi :: TH.Q a -> TcM a
-runQuasi act = TH.runQ act
+runQinTcM :: TH.Q a -> TcM a
+runQinTcM (TH.Q act) = withRunInIO $ \runInIO -> act (metaHandlersTcM runInIO)
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
- runQuasi $ sequence_ qs
+ runQinTcM $ sequence_ qs
#endif
ExternalInterp ext -> withExtInterp ext $ \inst -> do
@@ -1466,70 +1467,14 @@ when showing an error message.
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
-}
-instance TH.Quasi TcM where
- qNewName s = do { u <- newUnique
- ; let i = toInteger (getKey u)
- ; return (TH.mkNameU s i) }
+-- 'msg' is forced to ensure exceptions don't escape,
+-- see Note [Exceptions in TH]
+report :: Bool -> [Char] -> TcM ()
+report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
+report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
- -- 'msg' is forced to ensure exceptions don't escape,
- -- see Note [Exceptions in TH]
- qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
- qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
-
- qLocation :: TcM TH.Loc
- qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; r <- case l of
- RealSrcSpan s _ -> return s
- GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
- (pprGeneratedSrcSpanDetails)
- UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
- (ppr l)
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = unitString (moduleUnit m)
- , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
- , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
-
- qLookupName = lookupName
- qReify = reify
- qReifyFixity nm = lookupThName nm >>= reifyFixity
- qReifyType = reifyTypeOfThing
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness nm = do { nm' <- lookupThName nm
- ; dc <- tcLookupDataCon nm'
- ; let bangs = dataConImplBangs dc
- ; return (map reifyDecidedStrictness bangs) }
-
- -- For qRecover, discard error messages if
- -- the recovery action is chosen. Otherwise
- -- we'll only fail higher up.
- qRecover recover main = tryTcDiscardingErrs recover main
-
- qGetPackageRoot = do
- dflags <- getDynFlags
- return $ fromMaybe "." (workingDirectory dflags)
-
- qAddDependentFile fp = do
- ref <- fmap tcg_dependent_files getGblEnv
- dep_files <- readTcRef ref
- writeTcRef ref (fp:dep_files)
-
- qAddDependentDirectory dp = do
- ref <- fmap tcg_dependent_dirs getGblEnv
- dep_dirs <- readTcRef ref
- writeTcRef ref (dp:dep_dirs)
-
- qAddTempFile suffix = do
- dflags <- getDynFlags
- logger <- getLogger
- tmpfs <- hsc_tmpfs <$> getTopEnv
- liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
-
- qAddTopDecls thds = do
+addTopDecls :: [TH.Dec] -> TcM ()
+addTopDecls thds = do
exts <- fmap extensionFlags getDynFlags
l <- getSrcSpanM
th_origin <- getThSpliceOrigin
@@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where
bindName :: RdrName -> TcM ()
bindName (Exact n)
= do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
- ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
- }
+ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+ }
bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name
- qAddForeignFilePath lang fp = do
- var <- fmap tcg_th_foreign_files getGblEnv
- updTcRef var ((lang, fp) :)
-
- qAddModFinalizer fin = do
- r <- liftIO $ mkRemoteRef fin
- fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
- addModFinalizerRef fref
-
- qAddCorePlugin plugin = do
- hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let home_unit = hsc_home_unit hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
- let err = TcRnTHError $ AddInvalidCorePlugin plugin
- case r of
- Found {} -> addErr err
- FoundMultiple {} -> addErr err
- _ -> return ()
- th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
- updTcRef th_coreplugins_var (plugin:)
-
- qGetQ :: forall a. Typeable a => TcM (Maybe a)
- qGetQ = do
- th_state_var <- fmap tcg_th_state getGblEnv
- th_state <- readTcRef th_state_var
- -- See #10596 for why we use a scoped type variable here.
- return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
-
- qPutQ x = do
- th_state_var <- fmap tcg_th_state getGblEnv
- updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
-
- qIsExtEnabled = xoptM
-
- qExtsEnabled =
- EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
-
- qPutDoc doc_loc s = do
+putDoc :: TH.DocLoc -> String -> TcM ()
+putDoc doc_loc s = do
th_doc_var <- tcg_th_docs <$> getGblEnv
resolved_doc_loc <- resolve_loc doc_loc
is_local <- checkLocalName resolved_doc_loc
@@ -1624,15 +1530,131 @@ instance TH.Quasi TcM where
checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
checkLocalName ModuleDoc = pure True
-
- qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
- qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
- qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
- qGetDoc TH.ModuleDoc = do
+getDoc :: TH.DocLoc -> TcM (Maybe String)
+getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
+getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
+getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
+getDoc TH.ModuleDoc = do
df <- getDynFlags
docs <- getGblEnv >>= extractDocs df
return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
+getQ :: forall a. Typeable a => TcM (Maybe a)
+getQ = do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ th_state <- readTcRef th_state_var
+ -- See #10596 for why we use a scoped type variable here.
+ return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+location :: TcM TH.Loc
+location = do { m <- getModule
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ RealSrcSpan s _ -> return s
+ GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
+ (pprGeneratedSrcSpanDetails)
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = unitString (moduleUnit m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
+metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers
+metaHandlersTcM runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
+ , mFail = \s -> runInIO $ fail @TcM s
+ , mNewName = \s -> runInIO $ do { u <- newUnique
+ ; let i = toInteger (getKey u)
+ ; return (TH.mkNameU s i) }
+
+ , mReport = fmap runInIO . report
+
+ , mLocation = runInIO location
+
+ , mLookupName = fmap runInIO . lookupName
+ , mReify = runInIO . reify
+ , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity
+ , mReifyType = runInIO . reifyTypeOfThing
+ , mReifyInstances = fmap runInIO . reifyInstances
+ , mReifyRoles = runInIO . reifyRoles
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = runInIO . reifyModule
+ , mReifyConStrictness = \nm -> runInIO $ do
+ { nm' <- lookupThName nm
+ ; dc <- tcLookupDataCon nm'
+ ; let bangs = dataConImplBangs dc
+ ; return (map reifyDecidedStrictness bangs) }
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up.
+ , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main)
+
+ , mGetPackageRoot = runInIO $ do
+ dflags <- getDynFlags
+ return $ fromMaybe "." (workingDirectory dflags)
+
+ , mAddDependentFile = \fp -> runInIO $ do
+ ref <- fmap tcg_dependent_files getGblEnv
+ dep_files <- readTcRef ref
+ writeTcRef ref (fp:dep_files)
+
+ , mAddDependentDirectory = \dp -> runInIO $ do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
+ , mAddTempFile = \suffix -> runInIO $ do
+ dflags <- getDynFlags
+ logger <- getLogger
+ tmpfs <- hsc_tmpfs <$> getTopEnv
+ liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
+
+ , mAddTopDecls = runInIO . addTopDecls
+
+ , mAddForeignFilePath = \lang fp -> runInIO $ do
+ var <- fmap tcg_th_foreign_files getGblEnv
+ updTcRef var ((lang, fp) :)
+
+ , mAddModFinalizer = \fin -> runInIO $ do
+ r <- liftIO $ mkRemoteRef fin
+ fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+ addModFinalizerRef fref
+
+ , mAddCorePlugin = \plugin -> runInIO $ do
+ hsc_env <- getTopEnv
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ let fopts = initFinderOpts dflags
+ r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
+ let err = TcRnTHError $ AddInvalidCorePlugin plugin
+ case r of
+ Found {} -> addErr err
+ FoundMultiple {} -> addErr err
+ _ -> return ()
+ th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+ updTcRef th_coreplugins_var (plugin:)
+
+ , mGetQ = runInIO getQ
+
+ , mPutQ = \x -> runInIO $ do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+ , mIsExtEnabled = runInIO . xoptM
+
+ , mExtsEnabled = runInIO $
+ EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+ , mPutDoc = fmap runInIO . putDoc
+
+ , mGetDoc = runInIO . getDoc
+ }
+
-- | Looks up documentation for a declaration in first the current module,
-- otherwise tries to find it in another module via 'hscGetModuleInterface'.
lookupDeclDoc :: Name -> TcM (Maybe String)
@@ -1788,7 +1810,7 @@ runTH ty fhv = do
InternalInterp -> do
-- Run it in the local TcM
hv <- liftIO $ wormhole interp fhv
- r <- runQuasi (unsafeCoerce hv :: TH.Q a)
+ r <- runQinTcM (unsafeCoerce hv :: TH.Q a)
return r
#endif
@@ -1797,7 +1819,7 @@ runTH ty fhv = do
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
rstate <- getTHState inst
- loc <- TH.qLocation
+ loc <- location
-- run a remote TH request
r <- liftIO $
withForeignRef rstate $ \state_hv ->
@@ -1913,32 +1935,32 @@ wrapTHResult tcm = do
handleTHMessage :: THMessage a -> TcM a
handleTHMessage msg = case msg of
- NewName a -> wrapTHResult $ TH.qNewName a
- Report b str -> wrapTHResult $ TH.qReport b str
- LookupName b str -> wrapTHResult $ TH.qLookupName b str
- Reify n -> wrapTHResult $ TH.qReify n
- ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
- ReifyType n -> wrapTHResult $ TH.qReifyType n
- ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
- ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+ NewName a -> wrapTHResult $ runQinTcM $ TH.newName a
+ Report b str -> wrapTHResult $ runQinTcM $ TH.report b str
+ LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str
+ Reify n -> wrapTHResult $ runQinTcM $ TH.reify n
+ ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n
+ ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n
+ ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
+ ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
ReifyAnnotations lookup tyrep ->
wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
- ReifyModule m -> wrapTHResult $ TH.qReifyModule m
- ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
- GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
- AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
- AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
- AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+ ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
+ ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
+ GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
+ AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d
+ AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
- AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
- AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
- AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
- IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
- ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
- PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
- GetDoc l -> wrapTHResult $ TH.qGetDoc l
+ AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str
+ AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs
+ AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str
+ IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext
+ ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled
+ PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s
+ GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l
FailIfErrs -> wrapTHResult failIfErrsM
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasi :: TH.Q a -> TcM a
+runQinTcM :: TH.Q a -> TcM a
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
finishTH :: TcM ()
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec
withDecDoc doc dec = do
dec' <- dec
case doc_loc dec' of
- Just loc -> qAddModFinalizer $ qPutDoc loc doc
+ Just loc -> addModFinalizer $ putDoc loc doc
Nothing -> pure ()
pure dec'
where
@@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause]
-> [Maybe String] -- ^ Documentation to attach to arguments
-> Q Dec
funD_doc nm cs mfun_doc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = funD nm cs
case mfun_doc of
@@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the newtype declaration
-> Q Dec
newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeD ctxt tc tvs ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
maybe dec (flip withDecDoc dec) mdoc
@@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
-- ^ Documentation to attach to the instance declaration
-> Q Dec
dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
-- ^ Documentation to attach to the instance declaration
-> Q Dec
newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
-> [Maybe String] -- ^ Documentation to attach to the pattern arguments
-> Q Dec
patSynD_doc name args dir pat mdoc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = patSynD name args dir pat
maybe dec (flip withDecDoc dec) mdoc
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class (MonadIO (..))
-import System.IO (FilePath, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified Data.Kind as Kind (Type)
import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base (
Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String,
- flip, id, (.), (++),
+ flip, id, (.), (++), ($),
)
import GHC.Internal.Classes (not)
import GHC.Internal.Data.Data hiding (Fixity(..))
@@ -59,145 +59,150 @@ import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
import GHC.Internal.TH.Syntax
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addDependentDirectory'.
- qAddDependentDirectory :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
+-- | 'MetaHandlers' defines the interface between GHC and TH splices.
+-- This is an internal interface between two parts of the compiler,
+-- and should never be directly exposed to users.
+--
+-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH.
+-- With time the two interfaces may drift apart.
+--
+-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid
+-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion.
+--
+-- For more information about the historical design of this interface,
+-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700
+data MetaHandlers = MetaHandlers {
+ -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO'
+ mLiftIO :: forall a. IO a -> IO a
+ , mFail :: forall a. String -> IO a
+ -- | Fresh names. See 'newName'.
+ , mNewName :: String -> IO Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ , mReport :: Bool -> String -> IO ()
+
+ -- | See 'recover'.
+ , mRecover :: forall a. Q a -- ^ the error handler
+ -> Q a -- ^ action which may fail
+ -> IO a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ , mLookupName :: Bool -> String -> IO (Maybe Name)
+ -- | See 'reify'.
+ , mReify :: Name -> IO Info
+ -- | See 'reifyFixity'.
+ , mReifyFixity :: Name -> IO (Maybe Fixity)
+ -- | See 'reifyType'.
+ , mReifyType :: Name -> IO Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ , mReifyInstances :: Name -> [Type] -> IO [Dec]
+ -- | See 'reifyRoles'.
+ , mReifyRoles :: Name -> IO [Role]
+ -- | See 'reifyAnnotations'.
+ , mReifyAnnotations :: forall a. Data a => AnnLookup -> IO [a]
+ -- | See 'reifyModule'.
+ , mReifyModule :: Module -> IO ModuleInfo
+ -- | See 'reifyConStrictness'.
+ , mReifyConStrictness :: Name -> IO [DecidedStrictness]
+
+ -- | See 'location'.
+ , mLocation :: IO Loc
+
+ -- | See 'getPackageRoot'.
+ , mGetPackageRoot :: IO FilePath
+
+ -- | See 'addDependentFile'.
+ , mAddDependentFile :: FilePath -> IO ()
+
+ -- | See 'addDependentDirectory'.
+ , mAddDependentDirectory :: FilePath -> IO ()
+
+ -- | See 'addTempFile'.
+ , mAddTempFile :: String -> IO FilePath
+
+ -- | See 'addTopDecls'.
+ , mAddTopDecls :: [Dec] -> IO ()
+
+ -- | See 'addForeignFilePath'.
+ , mAddForeignFilePath :: ForeignSrcLang -> String -> IO ()
+
+ -- | See 'addModFinalizer'.
+ , mAddModFinalizer :: Q () -> IO ()
+
+ -- | See 'addCorePlugin'.
+ , mAddCorePlugin :: String -> IO ()
+
+ -- | See 'getQ'.
+ , mGetQ :: forall a. Typeable a => IO (Maybe a)
+
+ -- | See 'putQ'.
+ , mPutQ :: forall a. Typeable a => a -> IO ()
+
+ -- | See 'isExtEnabled'.
+ , mIsExtEnabled :: Extension -> IO Bool
+ -- | See 'extsEnabled'.
+ , mExtsEnabled :: IO [Extension]
+
+ -- | See 'putDoc'.
+ , mPutDoc :: DocLoc -> String -> IO ()
+ -- | See 'getDoc'.
+ , mGetDoc :: DocLoc -> IO (Maybe String)
+ }
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
+badIO :: String -> IO a
+badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
- qAddDependentDirectory _ = badIO "AddDependentDirectory"
+metaHandlersIO :: MetaHandlers
+metaHandlersIO = MetaHandlers {
+ mLiftIO = id
+ , mFail = fail
+ , mNewName = newNameIO
+ , mReport = \b msg ->
+ if b then
+ hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ else
+ hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
+ , mLookupName = \ _ _ -> badIO "lookupName"
+ , mReify = \_ -> badIO "reify"
+ , mReifyFixity = \_ -> badIO "reifyFixity"
+ , mReifyType = \_ -> badIO "reifyFixity"
+ , mReifyInstances = \_ _ -> badIO "reifyInstances"
+ , mReifyRoles = \_ -> badIO "reifyRoles"
+ , mReifyAnnotations = \_ -> badIO "reifyAnnotations"
+ , mReifyModule = \_ -> badIO "reifyModule"
+ , mReifyConStrictness = \_ -> badIO "reifyConStrictness"
+ , mLocation = badIO "currentLocation"
+ , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this?
+ , mGetPackageRoot = badIO "getProjectRoot"
+ , mAddDependentFile = \_ -> badIO "addDependentFile"
+ , mAddTempFile = \_ -> badIO "addTempFile"
+ , mAddTopDecls = \_ -> badIO "addTopDecls"
+ , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath"
+ , mAddModFinalizer = \_ -> badIO "addModFinalizer"
+ , mAddCorePlugin = \_ -> badIO "addCorePlugin"
+ , mGetQ = badIO "getQ"
+ , mPutQ = \_ -> badIO "putQ"
+ , mIsExtEnabled = \_ -> badIO "isExtEnabled"
+ , mExtsEnabled = badIO "extsEnabled"
+ , mPutDoc = \_ _ -> badIO "putDoc"
+ , mGetDoc = \_ -> badIO "getDoc"
+ , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
+ }
instance Quote IO where
newName = newNameIO
+
+
newNameIO :: String -> IO Name
newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
; pure (mkNameU s n) }
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
-- Global variable to generate unique symbols
counter :: IORef Uniq
{-# NOINLINE counter #-}
@@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0)
--
-----------------------------------------------------
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
--- providing an abstract interface for the user which is later concretely
--- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
+-- | 'Q' is the base 'Monad' for TemplateHaskell splices,
+-- similar to how 'IO' is the base 'Monad' for normal Haskell programs.
+newtype Q a = Q { unQ :: MetaHandlers -> IO a }
instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
+ Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h)
(>>) = (*>)
instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
+ fail s = report True s >> Q (\h -> mFail h "Q monad failure")
instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
+ fmap f (Q x) = Q $ \h -> fmap f (x h)
instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
+ pure x = Q $ \_ -> pure x
+ Q f <*> Q x = Q $ \h -> (f h <*> x h)
+ Q m *> Q n = Q $ \h -> (m h *> n h)
-- | @since 2.17.0.0
instance Semigroup a => Semigroup (Q a) where
@@ -319,7 +302,7 @@ class Monad m => Quote m where
newName :: String -> m Name
instance Quote Q where
- newName s = Q (qNewName s)
+ newName s = Q $ \h -> mNewName h s
-----------------------------------------------------
--
@@ -517,35 +500,26 @@ joinCode = flip bindCode id
-- | Report an error (True) or warning (False),
-- but carry on; use 'fail' to stop.
report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
+report b s = Q $ \h -> mReport h b s
-- | Recover from errors raised by 'reportError' or 'fail'.
recover :: Q a -- ^ handler to invoke on failure
-> Q a -- ^ computation to run
-> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
+recover rec main = Q $ \h -> mRecover h rec main
-- We don't export lookupName; the Bool isn't a great API
-- Instead we export lookupTypeName, lookupValueName
lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
+lookupName ns s = Q $ \h -> mLookupName h ns s
-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
+lookupTypeName s = Q $ \h -> mLookupName h True s
-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
+lookupValueName s = Q $ \h -> mLookupName h False s
{-
Note [Name lookup]
@@ -620,7 +594,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName':
and to get information about @D@-the-type, use 'lookupTypeName'.
-}
reify :: Name -> Q Info
-reify v = Q (qReify v)
+reify v = Q $ \h -> mReify h v
{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@@ -629,7 +603,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
'Nothing', so you may assume @bar@ has 'defaultFixity'.
-}
reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
+reifyFixity nm = Q $ \h -> mReifyFixity h nm
{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
@reifyType 'not@ returns @Bool -> Bool@, and
@@ -637,7 +611,7 @@ reifyFixity nm = Q (qReifyFixity nm)
This works even if there's no explicit signature and the type or kind is inferred.
-}
reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
+reifyType nm = Q $ \h -> mReifyType h nm
{- | Template Haskell is capable of reifying information about types and
terms defined in previous declaration groups. Top-level declaration splices break up
@@ -729,7 +703,7 @@ has some discussion around this.
-}
reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
+reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys
{- | @reifyRoles nm@ returns the list of roles associated with the parameters
(both visible and invisible) of
@@ -748,20 +722,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
the role of the invisible @k@ parameter. Kind parameters are always nominal.
-}
reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
+reifyRoles nm = Q $ \h -> mReifyRoles h nm
-- | @reifyAnnotations target@ returns the list of annotations
-- associated with @target@. Only the annotations that are
-- appropriately typed is returned. So if you have @Int@ and @String@
-- annotations for the same target, you have to call this function twice.
reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
+reifyAnnotations an = Q $ \h -> mReifyAnnotations h an
-- | @reifyModule mod@ looks up information about module @mod@. To
-- look up the current module, call this function with the return
-- value of 'Language.Haskell.TH.Lib.thisModule'.
reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
+reifyModule m = Q $ \h -> mReifyModule h m
-- | @reifyConStrictness nm@ looks up the strictness information for the fields
-- of the constructor with the name @nm@. Note that the strictness information
@@ -776,7 +750,7 @@ reifyModule m = Q (qReifyModule m)
-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
-- @-XStrictData@ language extension was enabled.
reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
+reifyConStrictness n = Q $ \h -> mReifyConStrictness h n
-- | Is the list of instances returned by 'reifyInstances' nonempty?
--
@@ -789,7 +763,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
-- | The location at which this computation is spliced.
location :: Q Loc
-location = Q qLocation
+location = Q mLocation
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
-- Take care: you are guaranteed the ordering of calls to 'runIO' within
@@ -799,7 +773,7 @@ location = Q qLocation
-- necessarily flushed when the compiler finishes running, so you should
-- flush them yourself.
runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
+runIO m = Q $ \h -> mLiftIO h m
-- | Get the package root for the current package which is being compiled.
-- This can be set explicitly with the -package-root flag but is normally
@@ -811,7 +785,7 @@ runIO m = Q (qRunIO m)
-- change directory when compiling files but instead set the -package-root flag
-- appropriately.
getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
+getPackageRoot = Q mGetPackageRoot
-- | Record external directories that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +804,7 @@ getPackageRoot = Q qGetPackageRoot
-- * The state of the directory is read at the interface generation time,
-- not at the time of the function call.
addDependentDirectory :: FilePath -> Q ()
-addDependentDirectory dp = Q (qAddDependentDirectory dp)
+addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -844,17 +818,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp)
--
-- * The dependency is based on file content, not a modification time
addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
+addDependentFile fp = Q $ \h -> mAddDependentFile h fp
-- | Obtain a temporary file path with the given suffix. The compiler will
-- delete this file after compilation.
addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
+addTempFile suffix = Q $ \h -> mAddTempFile h suffix
-- | Add additional top-level declarations. The added declarations will be type
-- checked along with the current declaration group.
addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
+addTopDecls ds = Q $ \h -> mAddTopDecls h ds
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
@@ -863,7 +837,7 @@ addTopDecls ds = Q (qAddTopDecls ds)
-- This is a good alternative to 'addForeignSource' when you are trying to
-- directly link in an object file.
addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp
-- | Add a finalizer that will run in the Q monad after the current module has
-- been type checked. This only makes sense when run within a top-level splice.
@@ -872,7 +846,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-- 'reify' is able to find the local definitions when executed inside the
-- finalizer.
addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
+addModFinalizer act = Q $ \h -> mAddModFinalizer h act
-- | Adds a core plugin to the compilation pipeline.
--
@@ -882,7 +856,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act))
-- to tell the compiler that we needed to compile first a plugin module in the
-- current package.
addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
+addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin
-- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
-- a type-indexed finite map. That is,
@@ -896,20 +870,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin)
-- Note that the state is local to the Haskell module in which the Template
-- Haskell expression is executed.
getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
+getQ = Q mGetQ
-- | Replace the state in the 'Q' monad. Note that the state is local to the
-- Haskell module in which the Template Haskell expression is executed.
putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
+putQ x = Q $ \h -> mPutQ h x
-- | Determine whether the given language extension is enabled in the 'Q' monad.
isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
+isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext
-- | List all enabled language extensions.
extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
+extsEnabled = Q mExtsEnabled
-- | Add Haddock documentation to the specified location. This will overwrite
-- any documentation at the location if it already exists. This will reify the
@@ -928,48 +902,18 @@ extsEnabled = Q qExtsEnabled
-- Adding documentation to anything outside of the current module will cause an
-- error.
putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
+putDoc t s = Q $ \h -> mPutDoc h t s
-- | Retrieves the Haddock documentation at the specified location, if one
-- exists.
-- It can be used to read documentation on things defined outside of the current
-- module, provided that those modules were compiled with the @-haddock@ flag.
getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
+getDoc n = Q $ \h -> mGetDoc h n
instance MonadIO Q where
liftIO = runIO
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddDependentDirectory = addDependentDirectory
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
----------------------------------------------------
-- The following operations are used solely in GHC.HsToCore.Quote when
-- desugaring brackets. They are not necessary for the user, who can use
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
- TupleSections, RecordWildCards, InstanceSigs, CPP #-}
+ TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do
instance MonadIO GHCiQ where
liftIO m = GHCiQ $ \_ -> m
-instance TH.Quasi GHCiQ where
- qNewName str = ghcCmd (NewName str)
- qReport isError msg = ghcCmd (Report isError msg)
-
- -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
- qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
- s <- readIORef sRef
- remoteTHCall (qsPipe s) StartRecover
- e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
- remoteTHCall (qsPipe s) (EndRecover (isLeft e))
- case e of
- Left GHCiQException{} -> h sRef
- Right r -> return r
- qLookupName isType occ = ghcCmd (LookupName isType occ)
- qReify name = ghcCmd (Reify name)
- qReifyFixity name = ghcCmd (ReifyFixity name)
- qReifyType name = ghcCmd (ReifyType name)
- qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
- qReifyRoles name = ghcCmd (ReifyRoles name)
-
-- To reify annotations, we send GHC the AnnLookup and also the
-- TypeRep of the thing we're looking for, to avoid needing to
-- serialize irrelevant annotations.
- qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
- qReifyAnnotations lookup =
+reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+reifyAnnotations lookup =
map (deserializeWithData . B.unpack) <$>
ghcCmd (ReifyAnnotations lookup typerep)
where typerep = typeOf (undefined :: a)
- qReifyModule m = ghcCmd (ReifyModule m)
- qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
- qLocation = fromMaybe noLoc . qsLocation <$> getState
- qGetPackageRoot = ghcCmd GetPackageRoot
- qAddDependentFile file = ghcCmd (AddDependentFile file)
- qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
- qAddTempFile suffix = ghcCmd (AddTempFile suffix)
- qAddTopDecls decls = ghcCmd (AddTopDecls decls)
- qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
- qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
+runQinGHCiQ :: TH.Q a -> GHCiQ a
+runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef))
+ where
+ runInIO :: IORef QState -> GHCiQ a -> IO a
+ runInIO sRef (GHCiQ m) = m sRef
+
+metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers
+metaHandlersGHCiQ runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ , mFail = runInIO . fail
+ , mNewName = \str -> runInIO $ ghcCmd (NewName str)
+ , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg)
+
+ -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+ , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do
+ s <- readIORef sRef
+ remoteTHCall (qsPipe s) StartRecover
+ e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef
+ remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+ case e of
+ Left GHCiQException{} ->
+ runGHCiQ (runQinGHCiQ h) sRef
+ Right r -> return r
+ , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ)
+ , mReify = \name ->runInIO $ ghcCmd (Reify name)
+ , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name)
+ , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name)
+ , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys)
+ , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name)
+
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m)
+ , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name)
+ , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState
+ , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot
+ , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file)
+ , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir)
+ , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix)
+ , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls)
+ , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp)
+ , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>=
ghcCmd . AddModFinalizer
- qAddCorePlugin str = ghcCmd (AddCorePlugin str)
- qGetQ = do
+ , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str)
+ , mGetQ = runInIO $ do
s <- getState
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
return $ lookup (qsMap s)
- qPutQ k = GHCiQ $ \sRef ->
- modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
- qIsExtEnabled x = ghcCmd (IsExtEnabled x)
- qExtsEnabled = ghcCmd ExtsEnabled
- qPutDoc l s = ghcCmd (PutDoc l s)
- qGetDoc l = ghcCmd (GetDoc l)
+ , mPutQ = \k -> runInIO $ GHCiQ $ \sRef ->
+ modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+ , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x)
+ , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled
+ , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s)
+ , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l)
+}
-- | The implementation of the 'StartTH' message: create
-- a new IORef QState, and return a RemoteRef to it.
@@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do
qstateref <- localRef rstate
qstate <- readIORef qstateref
qstate' <- newIORef $ qstate { qsPipe = pipe }
- _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
+ _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'
return ()
-- | The implementation of the 'RunTH' message
@@ -272,5 +284,5 @@ runTHQ
runTHQ pipe rstate mb_loc ghciq = do
qstateref <- localRef rstate
modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
- r <- runGHCiQ (TH.runQ ghciq) qstateref
+ r <- runGHCiQ (runQinGHCiQ ghciq) qstateref
return $! LB.toStrict (runPut (put r))
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -5,13 +5,17 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Don't warn for using 'report' from ghc-internal
+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
module Language.Haskell.TH.Syntax (
Quote (..),
Exp (..),
Match (..),
Clause (..),
- Q (..),
+ Q,
+ -- backwards compatibility
+ Language.Haskell.TH.Syntax.unQ,
Pat (..),
Stmt (..),
Con (..),
@@ -202,11 +206,14 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Boot.TH.Monad
+import GHC.Boot.TH.Monad hiding (report)
+import qualified GHC.Boot.TH.Monad as Internal
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.IO (hPutStrLn, stderr)
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
-- and exports additionally functions that depend on @filepath@ or @System.IO@.
@@ -499,3 +506,170 @@ reassociate the tree as necessary.
-- Subsumed by the more general 'SpecialiseEP' constructor.
pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma
pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
+
+unQ :: Q a -> (forall m. Quasi m => m a)
+unQ m = runQ m
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ qRunQ :: Q a -> m a
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+ qNewName = qRunQ . newName
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+ qReport b s = qRunQ $ report b s
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ qLookupName ns s = qRunQ $ lookupName ns s
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ qReify v = qRunQ $ reify v
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ qReifyFixity v = qRunQ $ reifyFixity v
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ qReifyType v = qRunQ $ reifyType v
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ qReifyInstances cls tys = qRunQ $ reifyInstances cls tys
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ qReifyRoles nm = qRunQ $ reifyRoles nm
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ qReifyAnnotations an = qRunQ $ reifyAnnotations an
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ qReifyModule m = qRunQ $ reifyModule m
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+ qReifyConStrictness nm = qRunQ $ reifyConStrictness nm
+
+ -- | See 'location'.
+ qLocation :: m Loc
+ qLocation = qRunQ location
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+ qGetPackageRoot = qRunQ getPackageRoot
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+ qAddDependentFile p = qRunQ $ addDependentFile p
+
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+ qAddDependentDirectory p = qRunQ $ addDependentDirectory p
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+ qAddTempFile p = qRunQ $ addTempFile p
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+ qAddTopDecls decls = qRunQ $ addTopDecls decls
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+ qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+ qAddModFinalizer fin = qRunQ $ addModFinalizer fin
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+ qAddCorePlugin nm = qRunQ $ addCorePlugin nm
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+ qGetQ = qRunQ getQ
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+ qPutQ x = qRunQ $ putQ x
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ qIsExtEnabled ext = qRunQ $ isExtEnabled ext
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+ qExtsEnabled = qRunQ extsEnabled
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ qPutDoc l s = qRunQ $ putDoc l s
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+ qGetDoc l = qRunQ $ getDoc l
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ = qRunQ
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qRunQ (Q m) = m metaHandlersIO
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+
+instance Quasi Q where
+ qRunQ = id
+ qRecover = recover
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report = Internal.report
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -354,7 +354,6 @@ module Language.Haskell.TH where
type Pred = Type
type PredQ :: *
type PredQ = Q Pred
- type role Q nominal
type Q :: * -> *
newtype Q a = ...
type Quote :: (* -> *) -> Constraint
@@ -655,7 +654,7 @@ module Language.Haskell.TH where
roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec
ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr
runIO :: forall a. GHC.Internal.Types.IO a -> Q a
- runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a
+ runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a
safe :: Safety
sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
@@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where
data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
type Pred :: *
type Pred = Type
- type role Q nominal
type Q :: * -> *
- newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a}
+ newtype Q a = ...
type Quasi :: (* -> *) -> Constraint
class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where
+ qRunQ :: forall a. Q a -> m a
qNewName :: GHC.Internal.Base.String -> m Name
qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m ()
qRecover :: forall a. m a -> m a -> m a
@@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qRunQ, qRecover #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
@@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where
trueName :: Name
tupleDataName :: GHC.Internal.Types.Int -> Name
tupleTypeName :: GHC.Internal.Types.Int -> Name
+ unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a
unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp
unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp
unboxedSumDataName :: SumAlt -> SumArity -> Name
@@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif
instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60315570ab5f008d925098c1fff0f40…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60315570ab5f008d925098c1fff0f40…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/fix-prof-segv] Add test and changelog for #27123 fix.
by Andreas Klebinger (＠AndreasK) 19 Jun '26
by Andreas Klebinger (＠AndreasK) 19 Jun '26
19 Jun '26
Andreas Klebinger pushed to branch wip/andreask/fix-prof-segv at Glasgow Haskell Compiler / GHC
Commits:
62717c0e by Andreas Klebinger at 2026-06-19T08:31:21+00:00
Add test and changelog for #27123 fix.
- - - - -
3 changed files:
- + changelog.d/T27123.md
- + testsuite/tests/rts/T27123.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/T27123.md
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+synopsis: Fix two crashes that could happen in a multithreaded setting when profiling.
+description: There where two bugs that could cause occasional segfaults or crashes with
+an `PAP object entered` error when profiling. They only happened when two threads
+where racing to evaluate the same thunk, and specific GC timings.
+mrs: !16214
+issues: #27123
=====================================
testsuite/tests/rts/T27123.hs
=====================================
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
+-- against another thread or the GC evaluating a closure at the same time.
+
+module Main
+ -- (main)
+where
+
+import Control.Monad
+import Control.Concurrent
+import System.IO
+import GHC.Data.SmallArray
+import GHC.Exts
+import GHC.IO
+
+type Arr = SmallMutableArray RealWorld (Int->Int)
+
+io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
+io f = IO f
+
+io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
+io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
+
+{-# NOINLINE readSmallArray #-}
+readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
+ (# s2, r #) -> (# s2, r #)
+
+-- Continually overwrites the array with unevaluated thunks that will evaluated to
+-- a PAP under profiling.
+{-# NOINLINE mkThunks #-}
+mkThunks :: Arr -> IO ()
+mkThunks arr = do
+ forever $ do
+ yield
+ forM_ [0..100] $ \_j -> do
+ forM_ [0..5 :: Int] $ \i -> do
+ -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
+ let g = {-# SCC g #-} succ
+ io_ (writeSmallArray arr i g)
+
+-- Evaluate the array repeatedly in the given order.
+{-# NOINLINE evaluateThunks #-}
+evaluateThunks :: Arr -> [Int] -> IO ()
+evaluateThunks arr idxs = do
+ forever $ do
+ yield
+ -- putStr "." >> hFlush stdout
+ forM [0..5000::Int] $ \j -> do
+ forM_ idxs $ \i -> do
+ !g <- readSmallArray arr i
+ seq (g i) (pure ())
+
+main :: IO ()
+main = do
+ -- We spawn three threads. Two are evaluating the thunks in the array in opposite directions
+ -- One thread is
+ arr <- io (newSmallArray 6 (id))
+ _ <- forkIO $ do
+ evaluateThunks arr [0..5]
+ _ <- forkIO $ do
+ evaluateThunks arr [5,4..0]
+ forkIO $ mkThunks arr
+ threadDelay 30_000_000
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -687,3 +687,5 @@ test('ClosureTable',
['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
+
+test('T27123', [extra_ways(['optasm', 'prof'])], compile_and_run, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62717c0ecf776c842a8be86a7a8b2a8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62717c0ecf776c842a8be86a7a8b2a8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/25924] CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent
by Zubin (＠wz1000) 19 Jun '26
by Zubin (＠wz1000) 19 Jun '26
19 Jun '26
Zubin pushed to branch wip/25924 at Glasgow Haskell Compiler / GHC
Commits:
409a285a by Zubin Duggal at 2026-06-19T13:43:33+05:30
CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent
In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary
(which we generated because it absent).
Solution: Don't speculate on bindings we already know are absent.
Fixes 25924
- - - - -
8 changed files:
- + changelog.d/fix-absent-dict-projection
- compiler/GHC/CoreToStg/Prep.hs
- + testsuite/tests/core-to-stg/T25924/B.hs
- + testsuite/tests/core-to-stg/T25924/Main.hs
- + testsuite/tests/core-to-stg/T25924/all.T
- + testsuite/tests/core-to-stg/T25924a.hs
- + testsuite/tests/core-to-stg/T25924a.stdout
- testsuite/tests/core-to-stg/all.T
Changes:
=====================================
changelog.d/fix-absent-dict-projection
=====================================
@@ -0,0 +1,5 @@
+section: compiler
+synopsis: Fix a CorePrep miscompilation that could project a field out of an absent dictionary, resulting in a segfault.
+issues: #25924
+mrs: !16219
+description: We no longer speculatively evaluate bindings that we have already discovered are absent.
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2253,12 +2253,18 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,
| is_string = (CaseBound, TopLvlFloatable)
-- String literals are unboxed (so must be case-bound) and float to
-- the top-level
- | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable
+ | ok_for_spec
+ , not (isAbsDmd dmd) = (CaseBound, case lev of Unlifted -> LazyContextFloatable
Lifted -> TopLvlFloatable)
-- See Note [Speculative evaluation]
-- Ok-for-spec-eval things will be case-bound, lifted or not.
-- But when it's lifted we are ok with floating it to top-level
-- (where it is actually bound lazily).
+ --
+ -- Don't speculate an absent binding. Its RHS may project a field out of
+ -- a dictionary that we filled with a rubbish literal because the
+ -- dictionary was absent (see Note [Absent fillers]). Speculating it
+ -- forces that projection and results in a segfault. See #25924.
| Unlifted <- lev = (CaseBound, StrictContextFloatable)
| isStrUsedDmd dmd = (CaseBound, StrictContextFloatable)
-- These will never be floated out of a lazy RHS context
=====================================
testsuite/tests/core-to-stg/T25924/B.hs
=====================================
@@ -0,0 +1,89 @@
+{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-}
+module B where
+
+import Data.Kind
+
+class ABITypeable a where
+ abiTypeInfo :: String
+ abiTypeInfo = ""
+
+ unused :: a -> a
+ unused x = x
+
+data REF a
+
+instance ABITypeable () where
+instance ABITypeable a => ABITypeable (REF a) where
+
+class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint
+instance YulCatObj ()
+instance YulCatObj a => YulCatObj (REF a)
+
+type YulO1 a = YulCatObj a
+type YulO2 a b = (YulCatObj a, YulCatObj b)
+
+
+type YulCat :: Type -> Type -> Type
+data YulCat a b where
+ YulExtendType :: forall b. (YulO2 () b) => YulCat () b
+ YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b
+ YulJmpB :: forall a b. (YulO2 a b) => YulCat a b
+
+data Trie a b where
+ Z :: Trie a a
+ (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c
+
+type Cat a b = forall c. Trie b c -> Trie a c
+
+normalize :: forall a b unused ξ. (Int ~ unused, YulCatObj a, YulCatObj b)
+ => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ
+normalize t0 k = case t0 of
+ Z -> k Z undefined
+ φ :. f -> normalize f $ \f' s -> case f' of
+ Z -> k Z (s `YulComp` φ)
+ _ -> undefined
+
+
+toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b
+toSMC t = normalize (t Z) $ \f g -> case f of
+ Z -> g
+ _ -> error "toSMC: normalisation process failed"
+
+
+encode :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b)
+encode φ (Y f) = Y (\x -> f (φ :. x))
+
+
+type P :: Type -> Type -> Type
+data P r a = Y (Cat r a)
+
+fromP :: P r a -> Cat r a
+fromP (Y f) = f
+
+
+decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b
+decode f = toSMC (extract f)
+
+extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b
+extract f = fromP (f (Y id))
+
+
+yulShow :: YulCat a' b' -> String
+yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b
+yulShow (YulComp cb ac) = yulShow ac <> yulShow cb
+yulShow YulJmpB = "Jb"
+
+
+lfn' :: forall b unused.
+ ( YulO1 (REF b)
+ , () ~ unused
+ ) =>
+ (forall r. YulO1 r => P r () -> P r (REF b)) -> String
+lfn' f = yulShow (decode f)
+
+
+extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a
+extendType'l = encode YulExtendType
+
+keccak256'l :: forall a r. YulO2 r a => P r a -> P r ()
+keccak256'l = encode YulJmpB
=====================================
testsuite/tests/core-to-stg/T25924/Main.hs
=====================================
@@ -0,0 +1,14 @@
+module Main where
+import B
+
+getCounterRef' :: forall b r.
+ ( YulO1 b
+ , YulO1 r
+ -- , YulO1 (REF b)
+ ) =>
+ P r () -> P r (REF b)
+getCounterRef' a = extendType'l (keccak256'l a)
+{-# NOINLINE getCounterRef' #-}
+
+main :: IO ()
+main = putStrLn $ lfn' @() getCounterRef'
=====================================
testsuite/tests/core-to-stg/T25924/all.T
=====================================
@@ -0,0 +1,4 @@
+test('T25924',
+ [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])],
+ multimod_compile_and_run,
+ ['Main', '-O'])
=====================================
testsuite/tests/core-to-stg/T25924a.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-}
+module Main where
+
+class D a where
+ m :: a -> Int
+ m _ = 0
+ n :: a -> Int
+ n _ = 0
+
+class (D a, D a) => C a
+
+data T a
+
+instance D a => D (T a)
+instance C a => C (T a)
+
+instance D ()
+instance C ()
+
+data G where
+ MkG :: forall a. C (T a) => T a -> G
+
+sh :: G -> Int
+sh (MkG x) = m x
+
+f :: forall b. C b => G
+f = MkG (undefined :: T b)
+{-# NOINLINE f #-}
+
+main :: IO ()
+main = print (sh (f @()))
=====================================
testsuite/tests/core-to-stg/T25924a.stdout
=====================================
@@ -0,0 +1 @@
+0
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -8,3 +8,4 @@ test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp
test('T23865', normal, compile, ['-O -dlint'])
test('T24334', normal, compile_and_run, ['-O'])
test('T24463', normal, compile, ['-O'])
+test('T25924a', [ignore_stderr], compile_and_run, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f7957…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f7957…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Zubin pushed new branch wip/25924 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/25924
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/io-manager-deadlock-detection] 20 commits: Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
by Duncan Coutts (＠dcoutts) 19 Jun '26
by Duncan Coutts (＠dcoutts) 19 Jun '26
19 Jun '26
Duncan Coutts pushed to branch wip/io-manager-deadlock-detection at Glasgow Haskell Compiler / GHC
Commits:
a23f0d0a by Duncan Coutts at 2026-06-19T08:09:20+01:00
Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
We no longer need wakeupIOManager for the threaded RTS case, so we can
remove it and the bits only needed to support it. This includes the
pipe/eventfd fd shared between the RTS and the in-library I/O manager
used for waking up the I/O manager thread. The pipe/eventfd still
exists, but it no longer has to be communicated to the RTS, since the
RTS no longer needs to use it.
So we remove the RTS API export setIOManagerWakeupFd, and remove uses of
it within the I/O managers in ghc-internal.
- - - - -
f4c88345 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add a new interruptIOManager API for the I/O managers
It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the
return type and docs for awaitCompletedTimeoutsOrIO to have it return
false when it gets interrupted, and have no useful post condition in
that case.
- - - - -
a0b052a9 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for select I/O manager
Uses the FdWakup mechanism.
- - - - -
89b15fd6 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for poll I/O manager
Uses the FdWakup mechanism.
A quirk we have to cope with is that we now need to poll one more fd --
the wakeup_fd_r -- but this fd has no corresponding entry in the
aiop_table. This is awkward since we have set up our aiop_poll_table to
be an auxilliary table with matching indicies.
The solution this patch uses (and described in the comments) is to have
two tables: struct pollfd *aiop_poll_table, *full_poll_table;
and to have the aiop_poll_table alias the tail of the full_poll_table.
The head entry in the full_poll_table is the extra fd. So we poll the
full_poll_table, while the aiop_poll_table still has matching indicies
with the aiop_table.
Hurrah for C aliasing rules.
- - - - -
9e503496 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for win32 legacy I/O manager
And remove unused related helper resetAbandonRequestWait. It is not
called because the event is created in auto-reset mode, so never needs
to be reset manually.
- - - - -
8840ca5f by Duncan Coutts at 2026-06-19T08:09:20+01:00
Note lack of interruptIOManager support for WinIO I/O manager
Though there's a plausible design, we can't sanely test it at the moment
due to related WinIO bugs. Filed as issue #27403.
- - - - -
26b395ed by Duncan Coutts at 2026-06-19T08:32:49+01:00
Make signal handling be a respondibility of the I/O manager(s)
Previously it was scattered between I/O managers and the scheduler, and
especially the scheduler's deadlock detection.
Previously the scheduler would poll for pending signals each iteration
of the scheduler loop. The scheduler also had some hairy signal
functionality in the deadlock detection: in the non-threaded RTS (only)
if there were still no threads running after deadlock detection then it
would block waiting for signals.
But signals can and (in my opinion) should be thought of as just a funny
kind of I/O, and thus should be a responsibility of the I/O manager.
So now we have the I/O managers poll for signals when they are polling
for I/O completion (and removing the separate poll in the scheduler).
And when I/O managers block waiting for I/O then they now also start
signal handlers if they get interrupted by a signal. Crucially, if there
is no pending I/O or timers, the awaitCompletedTimeoutsOrIO will still
block waiting for signals.
This patch puts us into an intermediate state: it temporarily breaks
deadlock detection in the non-threaded RTS. The waiting on I/O currently
happens before deadlock detection. This means we'll now wait forever on
signals before doing deadlock detection. We need to move waiting after
deadlock detection. We'll do that in a later patch.
- - - - -
67e08f7e by Duncan Coutts at 2026-06-19T08:32:49+01:00
Clean up the RTS internal signal handling API
Now that the I/O manager is responsible for signals, we can simplify the
API we present for signal handling.
We now just need startPendingSignalHandlers, which is called from the
I/O managers. We can get rid of awaitUserSignals. We also don't need
RtsSignals.h to re-export the platform-specific posix/Signals.h or
win32/ConsoleHandler.h
We can also hide more of the implementation of signals. Less has to be
exposed in posix/Signals.h or win32/ConsoleHandler.h. Indeed,
posix/Signals.h becomes empty and we remove it. Partly this is because
we don't need inline functions (or macros) in the interface.
Also remove signal_handlers from RTS ABI exported symbols list. It does
not appear to have any users in the core libs, and its really an
internal implementation detail. It should not be exposed unless it's
really necessary.
- - - - -
f185da55 by Duncan Coutts at 2026-06-19T08:32:49+01:00
In the scheduler, move I/O blocking after deadlock detection
To make deadlock detection effective in the non-threaded RTS when there
are deadlocked threads and other unrelated threads waiting on I/O, we
need to arrange to do deadlock detection before we block in scheduler
to wait on I/O.
The solution is to:
1. adjust scheduleFindWork, which runs before deadlock detection, to
only poll for I/O and not block; and
2. add a step after deadlock detection to wait on I/O if there are
still no threads to run (and there's any I/O or timeouts outstanding)
The scheduleCheckBlockedThreads is now so simple that it made more sense
to inline it into scheduleFindWork.
- - - - -
6a0f27f4 by Duncan Coutts at 2026-06-19T08:32:49+01:00
Remove bogus anyPendingTimeoutsOrIO guard from scheduleDetectDeadlock
The deadlock detection was only invoked if both of these conditions
hold:
1. the run queue is empty
2. there is no pending I/O or timeouts
The second condition is unnecessary. The deadlock detection mechanism
can find deadlocks even if there are other threads waiting on I/O or
timers. Having this extra condition means that we fail to detect
blocked threads if there are any threads waiting on I/O or timers.
Part of fixing issue #26408
- - - - -
46aae717 by Duncan Coutts at 2026-06-19T08:32:49+01:00
Don't consider pending I/O for early context switch optimisation
Context switches are normally initiated by the timer signal. If however
the user specifies "context switch as often as possible", with +RTS -C0
then the scheduler arranges for an early context switch (when it's just
about to run a Haskell thread).
Context switching very often is expensive, so as an optimisation there
cases where we do not arrange an early context switch:
1. if there's no other threads to run
2. if there is no pending I/O or timers
This patch eliminates case 2, leaving only case 1.
The rationale is as follows. The use of this was inconsistent across
platforms and threaded/non-threaded RTS ways. It only worked on the
non-threaded RTS and on Windows only worked for the win32-legacy I/O
manager. On all other combinations anyPendingTimeoutsOrIO would always
return false. The fact that nobody noticed and complained about this
inconsistency suggests that the feature is not relied upon.
If however it turns out that applications do rely on this, then the
proper thing to do is not to restore this check, but to add a new I/O
manager hint function that returns if there is any pending events that
are likely to happen *soon*: for example timeouts expiring within one
timeslice, or I/O waits on things likely to complete soon like disk I/O,
but not for example socket/pipe I/O.
The motivation to avoid this use of anyPendingTimeoutsOrIO is to
allow us to eliminate anyPendingTimeoutsOrIO entirely. All other uses
of this are just guards on {await,poll}CompletedTimeoutsOrIO and
the guards can safely be folded into those functions. This will better
cope with some I/O managers having no proper implementation of
anyPendingTimeoutsOrIO.
Ultimately this will let us simplify the scheduler which currently has
to have special #ifdef mingw32_HOST_OS cases to cope with the lack of a
working anyPendingTimeoutsOrIO for some Windows I/O managers
- - - - -
e1cefda2 by Duncan Coutts at 2026-06-19T08:32:49+01:00
Remove anyPendingTimeoutsOrIO guarding {poll,await}CompletedTimeoutsOrIO
Previously the API of the I/O manager used a two step process: check
anyPendingTimeoutsOrIO and then call {poll,await}CompletedTimeoutsOrIO.
This was primarily there as a performance thing, to cheaply check if we
need to do anything.
And then because anyPendingTimeoutsOrIO existed, it was used for other
things too. We have now eliminated the other uses, and are just left
with the performance pattern.
But this was problematic because not all I/O managers correctly
implement anyPendingTimeoutsOrIO (specifically the win32 ones), and now
that we also make I/O managers responsible for signals then we need to
poll/await even if there is no pending I/O or timeouts. If there is no
pending I/O or timeouts then poll/await needs to degenerate to just
waiting forever for any signals.
- - - - -
e1be565f by Duncan Coutts at 2026-06-19T08:32:49+01:00
Remove anyPendingTimeoutsOrIO, it is no longer used
And this avoids the problems arising from the win32 I/O managers having
had a bogus implementation.
- - - - -
0051eb9f by Duncan Coutts at 2026-06-19T08:32:49+01:00
Remove second scheduler call to awaitCompletedTimeoutsOrIO
Previously awaitCompletedTimeoutsOrIO was called both before and after
deadlock detection in the scheduler. The reason for that was that the
win32 I/O managers had a bogus implementation of anyPendingTimeoutsOrIO
and this was used to guard the call of awaitCompletedTimeoutsOrIO prior
to deadlock detection. This meant the first call site was never actually
called when using the win32 I/O managers. This was the reason for the
second call: the first one was never used. What a mess.
So now we have a simple design in the scheduler:
1. poll for completed I/O, timers or signals
2. if no runnable threads: do deadlock detection
3. if still no runnable threads: block waiting for I/O, timers or
signals.
- - - - -
ab8c5a1f by Duncan Coutts at 2026-06-19T08:32:49+01:00
Lift emptyRunQueue guard out of scheduleDetectDeadlock
this improved the clarity of the logic when reading the scheduler code.
- - - - -
953effcf by Duncan Coutts at 2026-06-19T08:32:49+01:00
Make non-threaded deadlock detection also rely on idle GC
Only do deadlock detection GC when idle GC kicks in. This also relies on
using wakeUpRts, so now do this unconditionally. Previously wakeUpRts
was for the threaded rts only.
- - - - -
0a463c1c by Duncan Coutts at 2026-06-19T08:32:49+01:00
Enable idle GC by default on non-threaded RTS.
The behaviour is now uniform between threaded and non-threaded. The
deadlock detection now relies on idle GC for both threaded and
non-threaded ways. Previously deadlock detection did not rely on idle
GC for the non-threaded way.
- - - - -
da2b0853 by Duncan Coutts at 2026-06-19T08:32:49+01:00
Add a long Note [Deadlock detection]
It describes the historical and modern designs and their trade-offs.
The point is we've now unified the code for deadlock detection between
the threaded and non-threaded ways, by changing the non-threaded to
follow the same design as the threaded.
- - - - -
fa0f947a by Duncan Coutts at 2026-06-19T08:32:49+01:00
Add a test for deadlock detection, issue #26408
- - - - -
f2345a09 by Duncan Coutts at 2026-06-19T08:32:50+01:00
Update the user guide with the revised idle GC behaviour
i.e. it's now not just for the threaded RTS, but general.
Also document the fact that disabling idle GC also disables deadlock
detection.
And add a changelog entry.
- - - - -
32 changed files:
- + changelog.d/idle-gc-and-deadlock-detection
- docs/users_guide/runtime_control.rst
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/Linker.c
- rts/RtsFlags.c
- rts/RtsSignals.h
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/include/rts/IOInterface.h
- rts/posix/MIO.c
- rts/posix/MIO.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Select.h
- rts/posix/Signals.c
- − rts/posix/Signals.h
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- rts/win32/AwaitEvent.c
- rts/win32/AwaitEvent.h
- rts/win32/ConsoleHandler.c
- rts/win32/ConsoleHandler.h
- + testsuite/tests/rts/T26408.hs
- + testsuite/tests/rts/T26408.stderr
- testsuite/tests/rts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e248df7a530927e858a2c3e9bf1f5e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e248df7a530927e858a2c3e9bf1f5e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] 6 commits: Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
by Duncan Coutts (＠dcoutts) 19 Jun '26
by Duncan Coutts (＠dcoutts) 19 Jun '26
19 Jun '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC
Commits:
a23f0d0a by Duncan Coutts at 2026-06-19T08:09:20+01:00
Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
We no longer need wakeupIOManager for the threaded RTS case, so we can
remove it and the bits only needed to support it. This includes the
pipe/eventfd fd shared between the RTS and the in-library I/O manager
used for waking up the I/O manager thread. The pipe/eventfd still
exists, but it no longer has to be communicated to the RTS, since the
RTS no longer needs to use it.
So we remove the RTS API export setIOManagerWakeupFd, and remove uses of
it within the I/O managers in ghc-internal.
- - - - -
f4c88345 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add a new interruptIOManager API for the I/O managers
It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the
return type and docs for awaitCompletedTimeoutsOrIO to have it return
false when it gets interrupted, and have no useful post condition in
that case.
- - - - -
a0b052a9 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for select I/O manager
Uses the FdWakup mechanism.
- - - - -
89b15fd6 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for poll I/O manager
Uses the FdWakup mechanism.
A quirk we have to cope with is that we now need to poll one more fd --
the wakeup_fd_r -- but this fd has no corresponding entry in the
aiop_table. This is awkward since we have set up our aiop_poll_table to
be an auxilliary table with matching indicies.
The solution this patch uses (and described in the comments) is to have
two tables: struct pollfd *aiop_poll_table, *full_poll_table;
and to have the aiop_poll_table alias the tail of the full_poll_table.
The head entry in the full_poll_table is the extra fd. So we poll the
full_poll_table, while the aiop_poll_table still has matching indicies
with the aiop_table.
Hurrah for C aliasing rules.
- - - - -
9e503496 by Duncan Coutts at 2026-06-19T08:09:20+01:00
Add interruptIOManager support for win32 legacy I/O manager
And remove unused related helper resetAbandonRequestWait. It is not
called because the event is created in auto-reset mode, so never needs
to be reset manually.
- - - - -
8840ca5f by Duncan Coutts at 2026-06-19T08:09:20+01:00
Note lack of interruptIOManager support for WinIO I/O manager
Though there's a plausible design, we can't sanely test it at the moment
due to related WinIO bugs. Filed as issue #27403.
- - - - -
18 changed files:
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/RtsSymbols.c
- rts/include/rts/IOInterface.h
- rts/posix/MIO.c
- rts/posix/MIO.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Select.h
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- rts/win32/AwaitEvent.c
- rts/win32/AwaitEvent.h
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Internal.Show (Show)
import GHC.Internal.Types (Bool(..), Int, IO)
import GHC.Internal.Word (Word8)
import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)
-import GHC.Internal.Foreign.C.Types (CInt(..), CSize(..))
+import GHC.Internal.Foreign.C.Types (CSize(..))
import GHC.Internal.Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import GHC.Internal.Foreign.Marshal.Alloc (alloca, allocaBytes)
import GHC.Internal.Foreign.Marshal.Array (allocaArray)
@@ -51,7 +51,7 @@ import GHC.Internal.System.Posix.Types (Fd)
#if defined(HAVE_EVENTFD)
import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eBADF)
-import GHC.Internal.Foreign.C.Types (CULLong(..))
+import GHC.Internal.Foreign.C.Types (CInt(..), CULLong(..))
#else
import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF)
#endif
@@ -78,7 +78,10 @@ data Control = W {
, wakeupReadFd :: {-# UNPACK #-} !Fd
, wakeupWriteFd :: {-# UNPACK #-} !Fd
#endif
- , didRegisterWakeupFd :: !Bool
+ , didRegisterWakeupFd :: !Bool -- ^ Now redundant. Always False.
+ --TODO: remove ^^ this redundant field.
+ -- Technically, removing this is an API change to base. Sigh.
+
-- | Have this Control's fds been cleaned up?
, controlIsDead :: !(IORef Bool)
}
@@ -91,8 +94,8 @@ wakeupReadFd = controlEventFd
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
-newControl :: Bool -> IO Control
-newControl shouldRegister = allocaArray 2 $ \fds -> do
+newControl :: IO Control
+newControl = allocaArray 2 $ \fds -> do
let createPipe = do
throwErrnoIfMinus1_ "pipe" $ c_pipe fds
rd <- peekElemOff fds 0
@@ -108,10 +111,8 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlockingFD ev True
setCloseOnExec ev
- when shouldRegister $ c_setIOManagerWakeupFd ev
#else
(wake_rd, wake_wr) <- createPipe
- when shouldRegister $ c_setIOManagerWakeupFd wake_wr
#endif
isDead <- newIORef False
return W { controlReadFd = fromIntegral ctrl_rd
@@ -122,25 +123,16 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do
, wakeupReadFd = fromIntegral wake_rd
, wakeupWriteFd = fromIntegral wake_wr
#endif
- , didRegisterWakeupFd = shouldRegister
+ , didRegisterWakeupFd = False
, controlIsDead = isDead
}
-- | Close the control structure used by the IO manager thread.
--- N.B. If this Control is the Control whose wakeup file was registered with
--- the RTS, then *BEFORE* the wakeup file is closed, we must call
--- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
--- file after it has been closed.
---
--- Note, however, that even if we do the above, this function is still racy
--- since we do not synchronize between here and ioManagerWakeup.
--- ioManagerWakeup ignores failures that arise from this case.
closeControl :: Control -> IO ()
closeControl w = do
_ <- atomicSwapIORef (controlIsDead w) True
_ <- c_close . fromIntegral . controlReadFd $ w
_ <- c_close . fromIntegral . controlWriteFd $ w
- when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
#if defined(HAVE_EVENTFD)
_ <- c_close . fromIntegral . controlEventFd $ w
#else
@@ -248,11 +240,3 @@ foreign import ccall unsafe "sys/eventfd.h eventfd"
foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
-
-#if defined(wasm32_HOST_ARCH)
-c_setIOManagerWakeupFd :: CInt -> IO ()
-c_setIOManagerWakeupFd _ = return ()
-#else
-foreign import ccall unsafe "setIOManagerWakeupFd"
- c_setIOManagerWakeupFd :: CInt -> IO ()
-#endif
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
=====================================
@@ -194,7 +194,7 @@ newWith :: Backend -> IO EventManager
newWith be = do
iofds <- fmap (listArray (0, callbackArraySize-1)) $
replicateM callbackArraySize (newMVar =<< IT.new 8)
- ctrl <- newControl False
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
=====================================
@@ -126,7 +126,7 @@ new = newWith =<< newDefaultBackend
newWith :: Backend -> IO TimerManager
newWith be = do
timeouts <- newIORef Q.empty
- ctrl <- newControl True
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
rts/IOManager.c
=====================================
@@ -343,9 +343,7 @@ void initCapabilityIOManager(CapIOManager *iomgr)
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
case IO_MANAGER_SELECT:
- iomgr->blocked_queue_hd = END_TSO_QUEUE;
- iomgr->blocked_queue_tl = END_TSO_QUEUE;
- iomgr->sleeping_queue = END_TSO_QUEUE;
+ initCapabilityIOManagerSelect(iomgr);
break;
#endif
@@ -376,6 +374,12 @@ void initCapabilityIOManager(CapIOManager *iomgr)
void freeCapabilityIOManager(CapIOManager *iomgr)
{
switch (iomgr_type) {
+#if defined(IOMGR_ENABLED_SELECT)
+ case IO_MANAGER_SELECT:
+ freeCapabilityIOManagerSelect(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
freeCapabilityIOManagerPoll(iomgr);
@@ -555,42 +559,6 @@ exitIOManager(bool wait_threads)
}
}
-/* Wakeup hook: called from the scheduler's wakeUpRts (currently only in
- * threaded mode).
- */
-void wakeupIOManager(void)
-{
- switch (iomgr_type) {
-
-#if defined(IOMGR_ENABLED_MIO_POSIX)
- case IO_MANAGER_MIO_POSIX:
- /* MIO Posix implementation in posix/Signals.c */
- ioManagerWakeup();
- break;
-#endif
-#if defined(IOMGR_ENABLED_MIO_WIN32)
- case IO_MANAGER_MIO_WIN32:
- /* MIO Windows implementation in win32/ThrIOManager.c
- * Yes, this is shared with the WinIO (threaded) impl.
- */
- ioManagerWakeup();
- break;
-#endif
-#if defined(IOMGR_ENABLED_WINIO)
- case IO_MANAGER_WINIO:
-#if defined(THREADED_RTS)
- /* WinIO threaded implementation in win32/ThrIOManager.c
- * Yes, this is shared with the MIO win32 impl.
- */
- ioManagerWakeup();
-#endif
- break;
-#endif
- default:
- break;
- }
-}
-
void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr)
{
switch (iomgr_type) {
@@ -764,19 +732,20 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
}
-void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
+bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
{
debugTrace(DEBUG_iomanager, "waiting for completed IO or timeouts");
+ bool completed = true; // wait completed or interrupted?
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
case IO_MANAGER_SELECT:
- awaitCompletedTimeoutsOrIOSelect(iomgr, true);
+ completed = awaitCompletedTimeoutsOrIOSelect(iomgr, true);
break;
#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
- awaitCompletedTimeoutsOrIOPoll(iomgr);
+ completed = awaitCompletedTimeoutsOrIOPoll(iomgr);
break;
#endif
@@ -788,13 +757,56 @@ void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
#if defined(IOMGR_ENABLED_WINIO)
case IO_MANAGER_WINIO:
#endif
- awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true);
+ completed = awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true);
break;
#endif
default:
- barf("pollCompletedTimeoutsOrIO not implemented");
+ barf("awaitCompletedTimeoutsOrIO not implemented");
+ }
+ ASSERT(!emptyRunQueue(iomgr->cap) ||
+ getSchedState() != SCHED_RUNNING ||
+ !completed);
+ return completed;
+}
+
+
+/* Interrupt the I/O manager if it is blocked in awaitCompletedTimeoutsOrIO,
+ * causing it to return early and return false.
+ */
+void interruptIOManager(CapIOManager *iomgr)
+{
+ debugTrace(DEBUG_iomanager, "Interrupting the I/O manager...");
+ switch (iomgr_type) {
+
+#if defined(IOMGR_ENABLED_SELECT)
+ case IO_MANAGER_SELECT:
+ interruptIOManagerSelect(iomgr);
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_POLL)
+ case IO_MANAGER_POLL:
+ interruptIOManagerPoll(iomgr);
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_WIN32_LEGACY)
+ case IO_MANAGER_WIN32_LEGACY:
+ abandonRequestWait();
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_WINIO)
+ case IO_MANAGER_WINIO:
+ /* FIXME: no support yet for interrupting in WinIO I/O manager
+ * See issue #27403
+ */
+ break;
+#endif
+
+ default:
+ break;
}
- ASSERT(!emptyRunQueue(iomgr->cap) || getSchedState() != SCHED_RUNNING);
}
=====================================
rts/IOManager.h
=====================================
@@ -306,23 +306,6 @@ void stopIOManager(void);
void exitIOManager(bool wait_threads);
-/* Wakeup hook: called from the scheduler's wakeUpRts (currently only in
- * threaded mode).
- *
- * The I/O manager can be blocked waiting on I/O or timers. Sometimes there are
- * other external events where we need to wake up the I/O manager and return
- * to the schedulr.
- *
- * At the moment, all the non-threaded I/O managers will do this automagically
- * since a signal will interrupt any waiting system calls, so at the moment
- * the implementation for the non-threaded I/O managers does nothing.
- *
- * For the I/O managers in threaded mode, this arranges to unblock the I/O
- * manager if it waa blocked waiting.
- */
-void wakeupIOManager(void);
-
-
/* GC hook: mark any per-capability GC roots the I/O manager uses.
*/
void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr);
@@ -382,20 +365,32 @@ bool anyPendingTimeoutsOrIO(CapIOManager *iomgr);
*/
void pollCompletedTimeoutsOrIO(CapIOManager *iomgr);
- /* If there are any completed I/O operations or expired timers, process the
+/* If there are any completed I/O operations or expired timers, process the
* completions as appropriate. If there are none, wait until I/O or a timer
* does complete (or we get a signal with a handler) and process the
* completions as appropriate.
*
- * Upon return this guarantees that the scheduler run queue is non-empty or
- * that the scheduler is no longer in the running state. Succinctly, the
- * post-condition is (!emptyRunQueue(cap) || getSchedState() != SCHED_RUNNING).
+ * Upon returning true this guarantees that the scheduler run queue is
+ * non-empty or that the scheduler is no longer in the running state.
+ * Succinctly, the post-condition in the return true case is
+ * (!emptyRunQueue(cap) || getSchedState() != SCHED_RUNNING).
+ * A false result means the wait was interrupted by interruptIOManager, and
+ * there is no post-condition in this case.
*
* This is only expected to be called if anyPendingTimeoutsOrIO() returns true,
* i.e. there actually is something to wait for.
*
* Called from schedule() both *before* and *after* scheduleDetectDeadlock().
*/
-void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr);
+
+/* Interrupt the I/O manager if it is blocked in awaitCompletedTimeoutsOrIO,
+ * causing it to return early.
+ *
+ * Its use is inherently concurrent and racy: the interrupt races against any
+ * I/O or timer completion. This does not matter for the intended use case of
+ * returning control to the scheduler.
+ */
+void interruptIOManager(CapIOManager *iomgr);
#include "EndPrivate.h"
=====================================
rts/IOManagerInternals.h
=====================================
@@ -46,6 +46,11 @@ struct _CapIOManager {
StgTSO *sleeping_queue;
#endif
+#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+ /* FDs for waking up the I/O manager when it is blocked waiting */
+ int interrupt_fd_r, interrupt_fd_w;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
/* AIOP and timeout collections shared by several I/O manager impls */
ClosureTable aiop_table;
@@ -53,8 +58,11 @@ struct _CapIOManager {
#endif
#if defined(IOMGR_ENABLED_POLL)
- /* Auxiliary table with size and indexes matching the aiop_table */
- struct pollfd *aiop_poll_table;
+ /* 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
+ * the wakeup_fd_r above, so we can also poll that fd.
+ */
+ struct pollfd *aiop_poll_table, *full_poll_table;
#endif
#if defined(IOMGR_ENABLED_WIN32_LEGACY)
=====================================
rts/RtsSymbols.c
=====================================
@@ -265,7 +265,6 @@ extern char **environ;
#define RTS_USER_SIGNALS_SYMBOLS \
SymI_HasProto(setIOManagerControlFd) \
SymI_HasProto(setTimerManagerControlFd) \
- SymI_HasProto(setIOManagerWakeupFd) \
SymI_HasProto(blockUserSignals) \
SymI_HasProto(unblockUserSignals)
#else
=====================================
rts/include/rts/IOInterface.h
=====================================
@@ -33,7 +33,6 @@ void ioManagerFinished (void);
void setIOManagerControlFd (uint32_t cap_no, int fd);
void setTimerManagerControlFd(int fd);
-void setIOManagerWakeupFd (int fd);
#endif
=====================================
rts/posix/MIO.c
=====================================
@@ -30,27 +30,16 @@
#include <unistd.h>
// Here's the pipe into which we will send our signals
-static int io_manager_wakeup_fd = -1;
static int timer_manager_control_wr_fd = -1;
// TODO: Eliminate these globals. Put then into the CapIOManager, but the
// problem is these are shared across all caps, not per cap.
-#define IO_MANAGER_WAKEUP 0xff
#define IO_MANAGER_DIE 0xfe
-#define IO_MANAGER_SYNC 0xfd
void setTimerManagerControlFd(int fd) {
RELAXED_STORE(&timer_manager_control_wr_fd, fd);
}
-void
-setIOManagerWakeupFd (int fd)
-{
- // only called when THREADED_RTS, but unconditionally
- // compiled here because GHC.Event.Control depends on it.
- SEQ_CST_STORE(&io_manager_wakeup_fd, fd);
-}
-
#if defined(THREADED_RTS)
void timerManagerNotifySignal(int sig, siginfo_t *info)
{
@@ -81,40 +70,6 @@ void timerManagerNotifySignal(int sig, siginfo_t *info)
#endif
-/* -----------------------------------------------------------------------------
- * Wake up at least one IO or timer manager HS thread.
- * -------------------------------------------------------------------------- */
-void
-ioManagerWakeup (void)
-{
- int r;
- const int wakeup_fd = SEQ_CST_LOAD(&io_manager_wakeup_fd);
- // Wake up the IO Manager thread by sending a byte down its pipe
- if (wakeup_fd >= 0) {
-#if defined(HAVE_EVENTFD)
- StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP;
- r = write(wakeup_fd, (char *) &n, 8);
-#else
- StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP;
- r = write(wakeup_fd, &byte, 1);
-#endif
- /* N.B. If the TimerManager is shutting down as we run this
- * then there is a possibility that our first read of
- * io_manager_wakeup_fd is non-negative, but before we get to the
- * write the file is closed. If this occurs, io_manager_wakeup_fd
- * will be written into with -1 (GHC.Event.Control does this prior
- * to closing), so checking this allows us to distinguish this case.
- * To ensure we observe the correct ordering, we declare the
- * io_manager_wakeup_fd as volatile.
- * Since this is not an error condition, we do not print the error
- * message in this case.
- */
- if (r == -1 && SEQ_CST_LOAD(&io_manager_wakeup_fd) >= 0) {
- sysErrorBelch("ioManagerWakeup: write");
- }
- }
-}
-
#if defined(THREADED_RTS)
void
ioManagerDie (void)
@@ -157,7 +112,7 @@ ioManagerStart (void)
{
// Make sure the IO manager thread is running
Capability *cap;
- if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0 || SEQ_CST_LOAD(&io_manager_wakeup_fd) < 0) {
+ if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0) {
cap = rts_lock();
ioManagerStartCap(&cap);
rts_unlock(cap);
=====================================
rts/posix/MIO.h
=====================================
@@ -18,7 +18,6 @@
/* Communicating with the IO manager thread (see GHC.Conc).
*/
-void ioManagerWakeup (void);
#if defined(THREADED_RTS)
void ioManagerDie (void);
void ioManagerStart (void);
=====================================
rts/posix/Poll.c
=====================================
@@ -41,6 +41,7 @@
#include "IOManagerInternals.h"
#include "Timeout.h"
+#include "FdWakeup.h"
/******************************************************************************
@@ -107,8 +108,9 @@ timeout (if any) as the poll() timeout parameter.
The CapIOManager structure for this I/O manager contains:
ClosureTable aiop_table;
- struct pollfd *aiop_poll_table;
+ struct pollfd *aiop_poll_table, *full_poll_table;
StgTimeoutQueue *timeout_queue;
+ int interrupt_fd_r, interrupt_fd_w;
We also support the Linux-specific ppoll API which supports higher resolution
time delays -- nanoseconds rather than milliseconds as in classic poll(). It
@@ -117,6 +119,15 @@ also allows the signal mask to be adjusted, but we do not make use of this.
int ppoll(struct pollfd *fds, nfds_t nfds,
const struct timespec *tmo_p, const sigset_t *sigmask);
+We have both aiop_poll_table and full_poll_table. This is to cope with needing
+to wait on the special extra file descriptor interrupt_fd_r. This fd is used to
+support waking the I/O manager when we are blocked in a poll call. This
+requires waiting on an extra fd that has no corresponding entry in the
+aiop_table. To manage this quirk, we alias the aiop_poll_table to be the tail
+of the full_poll_table and have the first entry of the full_poll_table be the
+interrupt_fd_r. This means the aiop_poll_table indicies match up exactly with
+the aiop_table, but still allows the full_poll_table to have an extra entry.
+
******************************************************************************/
/* Forward declarations */
@@ -129,16 +140,25 @@ static void reportPollError(int res, nfds_t nfds) STG_NORETURN;
void initCapabilityIOManagerPoll(CapIOManager *iomgr)
{
initClosureTable(&iomgr->aiop_table, ClosureTableCompact);
- iomgr->aiop_poll_table = NULL;
iomgr->timeout_queue = emptyTimeoutQueue();
+
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+
+ iomgr->full_poll_table = stgMallocBytes(sizeof(struct pollfd) /* size 1 */,
+ "initCapabilityIOManagerPoll");
+ iomgr->full_poll_table[0] = (struct pollfd) {
+ .fd = iomgr->interrupt_fd_r,
+ .events = POLLIN,
+ .revents = 0
+ };
+ iomgr->aiop_poll_table = iomgr->full_poll_table+1; /* hence empty */
}
void freeCapabilityIOManagerPoll(CapIOManager *iomgr)
{
- if (iomgr->aiop_poll_table) {
- stgFree(iomgr->aiop_poll_table);
- }
+ stgFree(iomgr->full_poll_table);
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
}
@@ -283,7 +303,7 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
}
-static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
+static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
{
/* The scheme we use with poll is that we have a dense poll table, and a
* corresponding table that maps to the closure table index. The poll
@@ -293,6 +313,19 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
*/
debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
ncompletions);
+
+ bool interrupt;
+ /* If the interrupt_fd_r is ready, collect it */
+ if (iomgr->full_poll_table[0].revents) {
+ ASSERT(iomgr->full_poll_table[0].fd == iomgr->interrupt_fd_r);
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ ncompletions--;
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager");
+ } else {
+ interrupt = false;
+ }
+
struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
int n = ncompletions;
int i = 0;
@@ -345,11 +378,14 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
i++;
}
}
+ return interrupt;
}
void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
{
+ ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1);
+
if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
Time now = getProcessElapsedTime();
processTimeoutCompletions(iomgr, now);
@@ -357,20 +393,20 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
if (!isEmptyClosureTable(&iomgr->aiop_table)) {
- nfds_t nfds = sizeClosureTable(&iomgr->aiop_table);
+ nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1;
/* Poll for I/O readiness, without waiting. */
#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
/* We could use poll here, since we use no timeout, but for
consistency we use the same syscall as at the other call site. */
struct timespec tv = (struct timespec) { .tv_sec = 0, .tv_nsec = 0 };
- int res = ppoll(iomgr->aiop_poll_table, nfds, &tv, NULL);
+ int res = ppoll(iomgr->full_poll_table, nfds, &tv, NULL);
debugTrace(DEBUG_iomanager,
"ppoll(nfds = %d, timeout.sec = 0, timeout.nsec = 0) = %d",
nfds, res);
#else
- int res = poll(iomgr->aiop_poll_table, nfds, 0);
+ int res = poll(iomgr->full_poll_table, nfds, 0);
debugTrace(DEBUG_iomanager,
"poll(nfds = %d, timeout_ms = 0) = %d",
@@ -396,8 +432,12 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
}
-void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
+bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
{
+ bool interrupt = false; /* got woken up via interruptIOManager */
+
+ ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1);
+
/* Loop until we've woken up some threads. This loop is needed because the
* poll() 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
@@ -430,9 +470,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
#endif
/* Check for I/O readiness, possibly waiting. */
- nfds_t nfds = sizeClosureTable(&iomgr->aiop_table);
+ nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1;
#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
- int res = ppoll(iomgr->aiop_poll_table, nfds, timeout_ns, NULL);
+ int res = ppoll(iomgr->full_poll_table, nfds, timeout_ns, NULL);
debugTrace(DEBUG_iomanager,
"ppoll(nfds = %d, timeout.sec = %d, timeout.nsec = %d) = %d",
@@ -440,7 +480,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
timeout_ns == NULL ? 0 : timeout_ns->tv_nsec,
res);
#else
- int res = poll(iomgr->aiop_poll_table, nfds, timeout_ms);
+ int res = poll(iomgr->full_poll_table, nfds, timeout_ms);
debugTrace(DEBUG_iomanager,
"poll(nfds = %d, timeout_ms = %d) = %d",
@@ -462,7 +502,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
} else if (res > 0) {
int ncompletions = res;
ASSERT(ncompletions <= (int)nfds);
- processIOCompletions(iomgr, ncompletions);
+ 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.
@@ -490,7 +530,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
}
} while (emptyRunQueue(iomgr->cap)
+ && !interrupt
&& (getSchedState() == SCHED_RUNNING));
+ return !interrupt;
}
static void reportPollError(int res, nfds_t nfds)
@@ -509,6 +551,12 @@ static void reportPollError(int res, nfds_t nfds)
}
+void interruptIOManagerPoll(CapIOManager *iomgr)
+{
+ sendFdWakeup(iomgr->interrupt_fd_w);
+}
+
+
/* Helper function to double the size of the aiop_table and aiop_poll_table.
*/
static bool enlargeTables(CapIOManager *iomgr)
@@ -519,13 +567,17 @@ static bool enlargeTables(CapIOManager *iomgr)
bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity);
if (RTS_UNLIKELY(!ok)) return false;
- /* Update the auxiliary aiop_poll_table to match */
- struct pollfd *aiop_poll_table;
- aiop_poll_table = stgReallocBytes(iomgr->aiop_poll_table,
- sizeof(struct pollfd) * newcapacity,
- "Poll.c: enlargeTables");
- iomgr->aiop_poll_table = aiop_poll_table;
+ /* Update the auxiliary aiop_poll_table to match. The full_poll_table is
+ * one bigger than the aiop_poll_table, since it has an extra entry at the
+ * front for interrupt_fd_r, with no corresponding aiop. */
+ iomgr->full_poll_table =
+ stgReallocBytes(iomgr->full_poll_table,
+ sizeof(struct pollfd) * (newcapacity+1),
+ "Poll.c: enlargeTables");
+ iomgr->aiop_poll_table = iomgr->full_poll_table+1;
+
/* Initialise the new part of the aiop_poll_table */
+ struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
for (int i = oldcapacity; i < newcapacity; i++) {
aiop_poll_table[i] = (struct pollfd) {
.fd = -1,
=====================================
rts/posix/Poll.h
=====================================
@@ -32,7 +32,8 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop);
/* Scheduler operations */
bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr);
void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
-void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
+void interruptIOManagerPoll(CapIOManager *iomgr);
#endif /* IOMGR_ENABLED_POLL */
=====================================
rts/posix/Select.c
=====================================
@@ -22,6 +22,7 @@
#include "IOManagerInternals.h"
#include "Stats.h"
#include "GetTime.h"
+#include "FdWakeup.h"
# if defined(HAVE_SYS_SELECT_H)
# include <sys/select.h>
@@ -54,6 +55,25 @@
#define TimeToLowResTimeRoundUp(t) (t)
#endif
+void initCapabilityIOManagerSelect(CapIOManager *iomgr)
+{
+ iomgr->blocked_queue_hd = END_TSO_QUEUE;
+ iomgr->blocked_queue_tl = END_TSO_QUEUE;
+ iomgr->sleeping_queue = END_TSO_QUEUE;
+
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+}
+
+void freeCapabilityIOManagerSelect(CapIOManager *iomgr)
+{
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
+}
+
+void interruptIOManagerSelect(CapIOManager *iomgr)
+{
+ sendFdWakeup(iomgr->interrupt_fd_w);
+}
+
/*
* Return the time since the program started, in LowResTime,
* rounded down.
@@ -215,7 +235,7 @@ static enum FdState fdPollWriteState (int fd)
* not write handles.
*
*/
-void
+bool
awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
{
StgTSO *tso, *prev, *next;
@@ -225,6 +245,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
bool seen_bad_fd = false;
struct timeval tv, *ptv;
LowResTime now;
+ bool interrupt = false; /* got interrupted up via interruptIOManager */
IF_DEBUG(scheduler,
debugBelch("scheduler: checking for threads blocked on I/O");
@@ -243,7 +264,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
now = getLowResTimeOfDay();
if (wakeUpSleepingThreads(iomgr, now)) {
- return;
+ return true;
}
/*
@@ -252,6 +273,13 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
FD_ZERO(&rfd);
FD_ZERO(&wfd);
+ /* We're always interested in our interrupt fd */
+ {
+ int fd = iomgr->interrupt_fd_r;
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ FD_SET(fd, &rfd);
+ }
+
for(tso = iomgr->blocked_queue_hd;
tso != END_TSO_QUEUE;
tso = next) {
@@ -354,14 +382,14 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
#if defined(RTS_USER_SIGNALS)
if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) {
startSignalHandlers(iomgr->cap);
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
#endif
/* we were interrupted, return to the scheduler immediately.
*/
if (getSchedState() >= SCHED_INTERRUPTING) {
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
/* check for threads that need waking up
@@ -372,10 +400,17 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
* I/O and run them.
*/
if (!emptyRunQueue(iomgr->cap)) {
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
}
+ /* If the interrupt_fd_r is ready, collect it */
+ if (FD_ISSET(iomgr->interrupt_fd_r, &rfd)) {
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in select I/O manager");
+ }
+
/* Step through the waiting queue, unblocking every thread that now has
* a file descriptor in a ready state.
*/
@@ -458,7 +493,9 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
}
} while (wait && getSchedState() == SCHED_RUNNING
- && emptyRunQueue(iomgr->cap));
+ && emptyRunQueue(iomgr->cap)
+ && !interrupt);
+ return !interrupt;
}
#endif /* IOMGR_ENABLED_SELECT */
=====================================
rts/posix/Select.h
=====================================
@@ -15,7 +15,12 @@ typedef StgWord LowResTime;
LowResTime getDelayTarget (HsInt us);
-void awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait);
+void initCapabilityIOManagerSelect(CapIOManager *iomgr);
+void freeCapabilityIOManagerSelect(CapIOManager *iomgr);
+void wakeupIOManagerSelect(CapIOManager *iomgr);
+
+bool awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait);
+void interruptIOManagerSelect(CapIOManager *iomgr);
#include "EndPrivate.h"
=====================================
rts/win32/AsyncMIO.c
=====================================
@@ -221,8 +221,12 @@ shutdownAsyncIO(bool wait_threads)
* requests to make further progress. In the latter scenario,
* awaitRequests() will simply block waiting for worker threads
* to complete if the 'completedTable' is empty.
+ *
+ * The result reports if the wait completed successfully (typically with some
+ * work available), or was interrupted by abandonRequestWait(), with true
+ * meaning completed, and false meaning interrupted.
*/
-int
+bool
awaitRequests(bool wait)
{
#if !defined(THREADED_RTS)
@@ -246,7 +250,7 @@ start:
#endif
) {
OS_RELEASE_LOCK(&queue_lock);
- return 0;
+ return true;
}
if (completed_hw == 0) {
// empty table, drop lock and wait
@@ -259,22 +263,24 @@ start:
// a request was completed
break;
case WAIT_OBJECT_0 + 1:
+ // abandon_req_wait signaled, by abandonRequestWait()
+ return false;
case WAIT_TIMEOUT:
// timeout (unlikely) or told to abandon waiting
- return 0;
+ return true;
case WAIT_FAILED: {
DWORD dw = GetLastError();
fprintf(stderr, "awaitRequests: wait failed -- "
"error code: %lu\n", dw); fflush(stderr);
- return 0;
+ return true;
}
default:
fprintf(stderr, "awaitRequests: unexpected wait return "
"code %lu\n", dwRes); fflush(stderr);
- return 0;
+ return true;
}
} else {
- return 0;
+ return true;
}
goto start;
} else {
@@ -352,7 +358,7 @@ start:
completed_hw = 0;
ResetEvent(completed_req_event);
OS_RELEASE_LOCK(&queue_lock);
- return 1;
+ return true;
}
#endif /* !THREADED_RTS */
}
@@ -383,12 +389,6 @@ abandonRequestWait( void )
interruptIOManagerEvent ();
}
-void
-resetAbandonRequestWait( void )
-{
- ResetEvent(abandon_req_wait);
-}
-
#endif /* !defined(THREADED_RTS) */
HsInt rts_EINTR(void)
=====================================
rts/win32/AsyncMIO.h
=====================================
@@ -25,7 +25,7 @@ extern unsigned int addDoProcRequest(void* proc, void* param);
extern int startupAsyncIO(void);
extern void shutdownAsyncIO(bool wait_threads);
-extern int awaitRequests(bool wait);
+extern bool awaitRequests(bool wait);
extern void abandonRequestWait(void);
extern void resetAbandonRequestWait(void);
=====================================
rts/win32/AwaitEvent.c
=====================================
@@ -28,17 +28,21 @@
// Protected by sched_mutex.
static bool workerWaitingForRequests = false;
-void
+bool
awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
{
+ bool interrupt = false;
do {
/* Try to de-queue completed IO requests
*/
workerWaitingForRequests = true;
if (is_io_mng_native_p())
awaitAsyncRequests(wait);
+ /* FIXME: no support yet for interrupting in WinIO I/O manager
+ * See issue #27403
+ */
else
- awaitRequests(wait);
+ interrupt = !awaitRequests(wait);
workerWaitingForRequests = false;
// If a signal was raised, we need to service it
@@ -47,11 +51,12 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
// does it and I'm feeling too paranoid to refactor it today --SDM
if (stg_pending_events != 0) {
startSignalHandlers(cap);
- return;
+ // This will normally cause emptyRunQueue to become false and
+ // thus we will drop out of the loop.
}
- // The return value from awaitRequests() is a red herring: ignore
- // it. Return to the scheduler if !wait, or
+ // The return value from awaitRequests() reports if it was interrupted by
+ // abandonRequestWait(). Return to the scheduler if !wait, or
//
// - we were interrupted
// - the run-queue is now non- empty
@@ -59,6 +64,8 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
} while (wait
&& getSchedState() == SCHED_RUNNING
&& emptyRunQueue(cap)
+ && !interrupt
);
+ return !interrupt;
}
#endif
=====================================
rts/win32/AwaitEvent.h
=====================================
@@ -2,6 +2,6 @@
#include "BeginPrivate.h"
-void awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait);
+bool awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait);
#include "EndPrivate.h"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b3c5699faf19dfa81d8f98170048eb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b3c5699faf19dfa81d8f98170048eb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] 6 commits: FIXUP Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
by Duncan Coutts (＠dcoutts) 19 Jun '26
by Duncan Coutts (＠dcoutts) 19 Jun '26
19 Jun '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC
Commits:
49be0154 by Duncan Coutts at 2026-06-19T07:55:32+01:00
FIXUP Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
- - - - -
106385a9 by Duncan Coutts at 2026-06-19T07:55:32+01:00
Add a new interruptIOManager API for the I/O managers
It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the
return type and docs for awaitCompletedTimeoutsOrIO to have it return
false when it gets interrupted, and have no useful post condition in
that case.
- - - - -
e53ab496 by Duncan Coutts at 2026-06-19T07:55:32+01:00
Add interruptIOManager support for select I/O manager
Uses the FdWakup mechanism.
- - - - -
5dc8839a by Duncan Coutts at 2026-06-19T07:55:32+01:00
Add interruptIOManager support for poll I/O manager
Uses the FdWakup mechanism.
A quirk we have to cope with is that we now need to poll one more fd --
the wakeup_fd_r -- but this fd has no corresponding entry in the
aiop_table. This is awkward since we have set up our aiop_poll_table to
be an auxilliary table with matching indicies.
The solution this patch uses (and described in the comments) is to have
two tables: struct pollfd *aiop_poll_table, *full_poll_table;
and to have the aiop_poll_table alias the tail of the full_poll_table.
The head entry in the full_poll_table is the extra fd. So we poll the
full_poll_table, while the aiop_poll_table still has matching indicies
with the aiop_table.
Hurrah for C aliasing rules.
- - - - -
ef380c59 by Duncan Coutts at 2026-06-19T07:55:32+01:00
Add interruptIOManager support for win32 legacy I/O manager
And remove unused related helper resetAbandonRequestWait. It is not
called because the event is created in auto-reset mode, so never needs
to be reset manually.
- - - - -
b3c5699f by Duncan Coutts at 2026-06-19T07:55:32+01:00
Note lack of interruptIOManager support for WinIO I/O manager
Though there's a plausible design, we can't sanely test it at the moment
due to related WinIO bugs. Filed as issue #27403.
- - - - -
18 changed files:
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/RtsSymbols.c
- rts/include/rts/IOInterface.h
- rts/posix/MIO.c
- rts/posix/MIO.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Select.h
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- rts/win32/AwaitEvent.c
- rts/win32/AwaitEvent.h
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Internal.Show (Show)
import GHC.Internal.Types (Bool(..), Int, IO)
import GHC.Internal.Word (Word8)
import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)
-import GHC.Internal.Foreign.C.Types (CInt(..), CSize(..))
+import GHC.Internal.Foreign.C.Types (CSize(..))
import GHC.Internal.Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import GHC.Internal.Foreign.Marshal.Alloc (alloca, allocaBytes)
import GHC.Internal.Foreign.Marshal.Array (allocaArray)
@@ -51,7 +51,7 @@ import GHC.Internal.System.Posix.Types (Fd)
#if defined(HAVE_EVENTFD)
import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eBADF)
-import GHC.Internal.Foreign.C.Types (CULLong(..))
+import GHC.Internal.Foreign.C.Types (CInt(..), CULLong(..))
#else
import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF)
#endif
@@ -78,7 +78,10 @@ data Control = W {
, wakeupReadFd :: {-# UNPACK #-} !Fd
, wakeupWriteFd :: {-# UNPACK #-} !Fd
#endif
- , didRegisterWakeupFd :: !Bool
+ , didRegisterWakeupFd :: !Bool -- ^ Now redundant. Always False.
+ --TODO: remove ^^ this redundant field.
+ -- Technically, removing this is an API change to base. Sigh.
+
-- | Have this Control's fds been cleaned up?
, controlIsDead :: !(IORef Bool)
}
@@ -91,8 +94,8 @@ wakeupReadFd = controlEventFd
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
-newControl :: Bool -> IO Control
-newControl shouldRegister = allocaArray 2 $ \fds -> do
+newControl :: IO Control
+newControl = allocaArray 2 $ \fds -> do
let createPipe = do
throwErrnoIfMinus1_ "pipe" $ c_pipe fds
rd <- peekElemOff fds 0
@@ -108,10 +111,8 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlockingFD ev True
setCloseOnExec ev
- when shouldRegister $ c_setIOManagerWakeupFd ev
#else
(wake_rd, wake_wr) <- createPipe
- when shouldRegister $ c_setIOManagerWakeupFd wake_wr
#endif
isDead <- newIORef False
return W { controlReadFd = fromIntegral ctrl_rd
@@ -122,25 +123,16 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do
, wakeupReadFd = fromIntegral wake_rd
, wakeupWriteFd = fromIntegral wake_wr
#endif
- , didRegisterWakeupFd = shouldRegister
+ , didRegisterWakeupFd = False
, controlIsDead = isDead
}
-- | Close the control structure used by the IO manager thread.
--- N.B. If this Control is the Control whose wakeup file was registered with
--- the RTS, then *BEFORE* the wakeup file is closed, we must call
--- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
--- file after it has been closed.
---
--- Note, however, that even if we do the above, this function is still racy
--- since we do not synchronize between here and ioManagerWakeup.
--- ioManagerWakeup ignores failures that arise from this case.
closeControl :: Control -> IO ()
closeControl w = do
_ <- atomicSwapIORef (controlIsDead w) True
_ <- c_close . fromIntegral . controlReadFd $ w
_ <- c_close . fromIntegral . controlWriteFd $ w
- when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
#if defined(HAVE_EVENTFD)
_ <- c_close . fromIntegral . controlEventFd $ w
#else
@@ -248,11 +240,3 @@ foreign import ccall unsafe "sys/eventfd.h eventfd"
foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
-
-#if defined(wasm32_HOST_ARCH)
-c_setIOManagerWakeupFd :: CInt -> IO ()
-c_setIOManagerWakeupFd _ = return ()
-#else
-foreign import ccall unsafe "setIOManagerWakeupFd"
- c_setIOManagerWakeupFd :: CInt -> IO ()
-#endif
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
=====================================
@@ -194,7 +194,7 @@ newWith :: Backend -> IO EventManager
newWith be = do
iofds <- fmap (listArray (0, callbackArraySize-1)) $
replicateM callbackArraySize (newMVar =<< IT.new 8)
- ctrl <- newControl False
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
=====================================
@@ -126,7 +126,7 @@ new = newWith =<< newDefaultBackend
newWith :: Backend -> IO TimerManager
newWith be = do
timeouts <- newIORef Q.empty
- ctrl <- newControl True
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
rts/IOManager.c
=====================================
@@ -343,9 +343,7 @@ void initCapabilityIOManager(CapIOManager *iomgr)
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
case IO_MANAGER_SELECT:
- iomgr->blocked_queue_hd = END_TSO_QUEUE;
- iomgr->blocked_queue_tl = END_TSO_QUEUE;
- iomgr->sleeping_queue = END_TSO_QUEUE;
+ initCapabilityIOManagerSelect(iomgr);
break;
#endif
@@ -376,6 +374,12 @@ void initCapabilityIOManager(CapIOManager *iomgr)
void freeCapabilityIOManager(CapIOManager *iomgr)
{
switch (iomgr_type) {
+#if defined(IOMGR_ENABLED_SELECT)
+ case IO_MANAGER_SELECT:
+ freeCapabilityIOManagerSelect(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
freeCapabilityIOManagerPoll(iomgr);
@@ -555,42 +559,6 @@ exitIOManager(bool wait_threads)
}
}
-/* Wakeup hook: called from the scheduler's wakeUpRts (currently only in
- * threaded mode).
- */
-void wakeupIOManager(void)
-{
- switch (iomgr_type) {
-
-#if defined(IOMGR_ENABLED_MIO_POSIX)
- case IO_MANAGER_MIO_POSIX:
- /* MIO Posix implementation in posix/Signals.c */
- ioManagerWakeup();
- break;
-#endif
-#if defined(IOMGR_ENABLED_MIO_WIN32)
- case IO_MANAGER_MIO_WIN32:
- /* MIO Windows implementation in win32/ThrIOManager.c
- * Yes, this is shared with the WinIO (threaded) impl.
- */
- ioManagerWakeup();
- break;
-#endif
-#if defined(IOMGR_ENABLED_WINIO)
- case IO_MANAGER_WINIO:
-#if defined(THREADED_RTS)
- /* WinIO threaded implementation in win32/ThrIOManager.c
- * Yes, this is shared with the MIO win32 impl.
- */
- ioManagerWakeup();
-#endif
- break;
-#endif
- default:
- break;
- }
-}
-
void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr)
{
switch (iomgr_type) {
@@ -764,19 +732,20 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
}
-void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
+bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
{
debugTrace(DEBUG_iomanager, "waiting for completed IO or timeouts");
+ bool completed = true; // wait completed or interrupted?
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
case IO_MANAGER_SELECT:
- awaitCompletedTimeoutsOrIOSelect(iomgr, true);
+ completed = awaitCompletedTimeoutsOrIOSelect(iomgr, true);
break;
#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
- awaitCompletedTimeoutsOrIOPoll(iomgr);
+ completed = awaitCompletedTimeoutsOrIOPoll(iomgr);
break;
#endif
@@ -788,13 +757,56 @@ void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
#if defined(IOMGR_ENABLED_WINIO)
case IO_MANAGER_WINIO:
#endif
- awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true);
+ completed = awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true);
break;
#endif
default:
- barf("pollCompletedTimeoutsOrIO not implemented");
+ barf("awaitCompletedTimeoutsOrIO not implemented");
+ }
+ ASSERT(!emptyRunQueue(iomgr->cap) ||
+ getSchedState() != SCHED_RUNNING ||
+ !completed);
+ return completed;
+}
+
+
+/* Interrupt the I/O manager if it is blocked in awaitCompletedTimeoutsOrIO,
+ * causing it to return early and return false.
+ */
+void interruptIOManager(CapIOManager *iomgr)
+{
+ debugTrace(DEBUG_iomanager, "Interrupting the I/O manager...");
+ switch (iomgr_type) {
+
+#if defined(IOMGR_ENABLED_SELECT)
+ case IO_MANAGER_SELECT:
+ interruptIOManagerSelect(iomgr);
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_POLL)
+ case IO_MANAGER_POLL:
+ interruptIOManagerPoll(iomgr);
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_WIN32_LEGACY)
+ case IO_MANAGER_WIN32_LEGACY:
+ abandonRequestWait();
+ break;
+#endif
+
+#if defined(IOMGR_ENABLED_WINIO)
+ case IO_MANAGER_WINIO:
+ /* FIXME: no support yet for interrupting in WinIO I/O manager
+ * See issue #27403
+ */
+ break;
+#endif
+
+ default:
+ break;
}
- ASSERT(!emptyRunQueue(iomgr->cap) || getSchedState() != SCHED_RUNNING);
}
=====================================
rts/IOManager.h
=====================================
@@ -306,23 +306,6 @@ void stopIOManager(void);
void exitIOManager(bool wait_threads);
-/* Wakeup hook: called from the scheduler's wakeUpRts (currently only in
- * threaded mode).
- *
- * The I/O manager can be blocked waiting on I/O or timers. Sometimes there are
- * other external events where we need to wake up the I/O manager and return
- * to the schedulr.
- *
- * At the moment, all the non-threaded I/O managers will do this automagically
- * since a signal will interrupt any waiting system calls, so at the moment
- * the implementation for the non-threaded I/O managers does nothing.
- *
- * For the I/O managers in threaded mode, this arranges to unblock the I/O
- * manager if it waa blocked waiting.
- */
-void wakeupIOManager(void);
-
-
/* GC hook: mark any per-capability GC roots the I/O manager uses.
*/
void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr);
@@ -382,20 +365,32 @@ bool anyPendingTimeoutsOrIO(CapIOManager *iomgr);
*/
void pollCompletedTimeoutsOrIO(CapIOManager *iomgr);
- /* If there are any completed I/O operations or expired timers, process the
+/* If there are any completed I/O operations or expired timers, process the
* completions as appropriate. If there are none, wait until I/O or a timer
* does complete (or we get a signal with a handler) and process the
* completions as appropriate.
*
- * Upon return this guarantees that the scheduler run queue is non-empty or
- * that the scheduler is no longer in the running state. Succinctly, the
- * post-condition is (!emptyRunQueue(cap) || getSchedState() != SCHED_RUNNING).
+ * Upon returning true this guarantees that the scheduler run queue is
+ * non-empty or that the scheduler is no longer in the running state.
+ * Succinctly, the post-condition in the return true case is
+ * (!emptyRunQueue(cap) || getSchedState() != SCHED_RUNNING).
+ * A false result means the wait was interrupted by interruptIOManager, and
+ * there is no post-condition in this case.
*
* This is only expected to be called if anyPendingTimeoutsOrIO() returns true,
* i.e. there actually is something to wait for.
*
* Called from schedule() both *before* and *after* scheduleDetectDeadlock().
*/
-void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr);
+
+/* Interrupt the I/O manager if it is blocked in awaitCompletedTimeoutsOrIO,
+ * causing it to return early.
+ *
+ * Its use is inherently concurrent and racy: the interrupt races against any
+ * I/O or timer completion. This does not matter for the intended use case of
+ * returning control to the scheduler.
+ */
+void interruptIOManager(CapIOManager *iomgr);
#include "EndPrivate.h"
=====================================
rts/IOManagerInternals.h
=====================================
@@ -46,6 +46,11 @@ struct _CapIOManager {
StgTSO *sleeping_queue;
#endif
+#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+ /* FDs for waking up the I/O manager when it is blocked waiting */
+ int interrupt_fd_r, interrupt_fd_w;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
/* AIOP and timeout collections shared by several I/O manager impls */
ClosureTable aiop_table;
@@ -53,8 +58,11 @@ struct _CapIOManager {
#endif
#if defined(IOMGR_ENABLED_POLL)
- /* Auxiliary table with size and indexes matching the aiop_table */
- struct pollfd *aiop_poll_table;
+ /* 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
+ * the wakeup_fd_r above, so we can also poll that fd.
+ */
+ struct pollfd *aiop_poll_table, *full_poll_table;
#endif
#if defined(IOMGR_ENABLED_WIN32_LEGACY)
=====================================
rts/RtsSymbols.c
=====================================
@@ -265,7 +265,6 @@ extern char **environ;
#define RTS_USER_SIGNALS_SYMBOLS \
SymI_HasProto(setIOManagerControlFd) \
SymI_HasProto(setTimerManagerControlFd) \
- SymI_HasProto(setIOManagerWakeupFd) \
SymI_HasProto(blockUserSignals) \
SymI_HasProto(unblockUserSignals)
#else
=====================================
rts/include/rts/IOInterface.h
=====================================
@@ -33,7 +33,6 @@ void ioManagerFinished (void);
void setIOManagerControlFd (uint32_t cap_no, int fd);
void setTimerManagerControlFd(int fd);
-void setIOManagerWakeupFd (int fd);
#endif
=====================================
rts/posix/MIO.c
=====================================
@@ -30,27 +30,16 @@
#include <unistd.h>
// Here's the pipe into which we will send our signals
-static int io_manager_wakeup_fd = -1;
static int timer_manager_control_wr_fd = -1;
// TODO: Eliminate these globals. Put then into the CapIOManager, but the
// problem is these are shared across all caps, not per cap.
-#define IO_MANAGER_WAKEUP 0xff
#define IO_MANAGER_DIE 0xfe
-#define IO_MANAGER_SYNC 0xfd
void setTimerManagerControlFd(int fd) {
RELAXED_STORE(&timer_manager_control_wr_fd, fd);
}
-void
-setIOManagerWakeupFd (int fd)
-{
- // only called when THREADED_RTS, but unconditionally
- // compiled here because GHC.Event.Control depends on it.
- SEQ_CST_STORE(&io_manager_wakeup_fd, fd);
-}
-
#if defined(THREADED_RTS)
void timerManagerNotifySignal(int sig, siginfo_t *info)
{
@@ -81,40 +70,6 @@ void timerManagerNotifySignal(int sig, siginfo_t *info)
#endif
-/* -----------------------------------------------------------------------------
- * Wake up at least one IO or timer manager HS thread.
- * -------------------------------------------------------------------------- */
-void
-ioManagerWakeup (void)
-{
- int r;
- const int wakeup_fd = SEQ_CST_LOAD(&io_manager_wakeup_fd);
- // Wake up the IO Manager thread by sending a byte down its pipe
- if (wakeup_fd >= 0) {
-#if defined(HAVE_EVENTFD)
- StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP;
- r = write(wakeup_fd, (char *) &n, 8);
-#else
- StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP;
- r = write(wakeup_fd, &byte, 1);
-#endif
- /* N.B. If the TimerManager is shutting down as we run this
- * then there is a possibility that our first read of
- * io_manager_wakeup_fd is non-negative, but before we get to the
- * write the file is closed. If this occurs, io_manager_wakeup_fd
- * will be written into with -1 (GHC.Event.Control does this prior
- * to closing), so checking this allows us to distinguish this case.
- * To ensure we observe the correct ordering, we declare the
- * io_manager_wakeup_fd as volatile.
- * Since this is not an error condition, we do not print the error
- * message in this case.
- */
- if (r == -1 && SEQ_CST_LOAD(&io_manager_wakeup_fd) >= 0) {
- sysErrorBelch("ioManagerWakeup: write");
- }
- }
-}
-
#if defined(THREADED_RTS)
void
ioManagerDie (void)
@@ -157,7 +112,7 @@ ioManagerStart (void)
{
// Make sure the IO manager thread is running
Capability *cap;
- if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0 || SEQ_CST_LOAD(&io_manager_wakeup_fd) < 0) {
+ if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0) {
cap = rts_lock();
ioManagerStartCap(&cap);
rts_unlock(cap);
=====================================
rts/posix/MIO.h
=====================================
@@ -18,7 +18,6 @@
/* Communicating with the IO manager thread (see GHC.Conc).
*/
-void ioManagerWakeup (void);
#if defined(THREADED_RTS)
void ioManagerDie (void);
void ioManagerStart (void);
=====================================
rts/posix/Poll.c
=====================================
@@ -41,6 +41,7 @@
#include "IOManagerInternals.h"
#include "Timeout.h"
+#include "FdWakeup.h"
/******************************************************************************
@@ -107,8 +108,9 @@ timeout (if any) as the poll() timeout parameter.
The CapIOManager structure for this I/O manager contains:
ClosureTable aiop_table;
- struct pollfd *aiop_poll_table;
+ struct pollfd *aiop_poll_table, *full_poll_table;
StgTimeoutQueue *timeout_queue;
+ int interrupt_fd_r, interrupt_fd_w;
We also support the Linux-specific ppoll API which supports higher resolution
time delays -- nanoseconds rather than milliseconds as in classic poll(). It
@@ -117,6 +119,15 @@ also allows the signal mask to be adjusted, but we do not make use of this.
int ppoll(struct pollfd *fds, nfds_t nfds,
const struct timespec *tmo_p, const sigset_t *sigmask);
+We have both aiop_poll_table and full_poll_table. This is to cope with needing
+to wait on the special extra file descriptor interrupt_fd_r. This fd is used to
+support waking the I/O manager when we are blocked in a poll call. This
+requires waiting on an extra fd that has no corresponding entry in the
+aiop_table. To manage this quirk, we alias the aiop_poll_table to be the tail
+of the full_poll_table and have the first entry of the full_poll_table be the
+interrupt_fd_r. This means the aiop_poll_table indicies match up exactly with
+the aiop_table, but still allows the full_poll_table to have an extra entry.
+
******************************************************************************/
/* Forward declarations */
@@ -129,16 +140,25 @@ static void reportPollError(int res, nfds_t nfds) STG_NORETURN;
void initCapabilityIOManagerPoll(CapIOManager *iomgr)
{
initClosureTable(&iomgr->aiop_table, ClosureTableCompact);
- iomgr->aiop_poll_table = NULL;
iomgr->timeout_queue = emptyTimeoutQueue();
+
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+
+ iomgr->full_poll_table = stgMallocBytes(sizeof(struct pollfd) /* size 1 */,
+ "initCapabilityIOManagerPoll");
+ iomgr->full_poll_table[0] = (struct pollfd) {
+ .fd = iomgr->interrupt_fd_r,
+ .events = POLLIN,
+ .revents = 0
+ };
+ iomgr->aiop_poll_table = iomgr->full_poll_table+1; /* hence empty */
}
void freeCapabilityIOManagerPoll(CapIOManager *iomgr)
{
- if (iomgr->aiop_poll_table) {
- stgFree(iomgr->aiop_poll_table);
- }
+ stgFree(iomgr->full_poll_table);
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
}
@@ -283,7 +303,7 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
}
-static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
+static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
{
/* The scheme we use with poll is that we have a dense poll table, and a
* corresponding table that maps to the closure table index. The poll
@@ -293,6 +313,19 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
*/
debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
ncompletions);
+
+ bool interrupt;
+ /* If the interrupt_fd_r is ready, collect it */
+ if (iomgr->full_poll_table[0].revents) {
+ ASSERT(iomgr->full_poll_table[0].fd == iomgr->interrupt_fd_r);
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ ncompletions--;
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager");
+ } else {
+ interrupt = false;
+ }
+
struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
int n = ncompletions;
int i = 0;
@@ -345,11 +378,14 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions)
i++;
}
}
+ return interrupt;
}
void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
{
+ ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1);
+
if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
Time now = getProcessElapsedTime();
processTimeoutCompletions(iomgr, now);
@@ -357,20 +393,20 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
if (!isEmptyClosureTable(&iomgr->aiop_table)) {
- nfds_t nfds = sizeClosureTable(&iomgr->aiop_table);
+ nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1;
/* Poll for I/O readiness, without waiting. */
#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
/* We could use poll here, since we use no timeout, but for
consistency we use the same syscall as at the other call site. */
struct timespec tv = (struct timespec) { .tv_sec = 0, .tv_nsec = 0 };
- int res = ppoll(iomgr->aiop_poll_table, nfds, &tv, NULL);
+ int res = ppoll(iomgr->full_poll_table, nfds, &tv, NULL);
debugTrace(DEBUG_iomanager,
"ppoll(nfds = %d, timeout.sec = 0, timeout.nsec = 0) = %d",
nfds, res);
#else
- int res = poll(iomgr->aiop_poll_table, nfds, 0);
+ int res = poll(iomgr->full_poll_table, nfds, 0);
debugTrace(DEBUG_iomanager,
"poll(nfds = %d, timeout_ms = 0) = %d",
@@ -396,8 +432,12 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
}
-void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
+bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
{
+ bool interrupt = false; /* got woken up via interruptIOManager */
+
+ ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1);
+
/* Loop until we've woken up some threads. This loop is needed because the
* poll() 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
@@ -430,9 +470,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
#endif
/* Check for I/O readiness, possibly waiting. */
- nfds_t nfds = sizeClosureTable(&iomgr->aiop_table);
+ nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1;
#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
- int res = ppoll(iomgr->aiop_poll_table, nfds, timeout_ns, NULL);
+ int res = ppoll(iomgr->full_poll_table, nfds, timeout_ns, NULL);
debugTrace(DEBUG_iomanager,
"ppoll(nfds = %d, timeout.sec = %d, timeout.nsec = %d) = %d",
@@ -440,7 +480,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
timeout_ns == NULL ? 0 : timeout_ns->tv_nsec,
res);
#else
- int res = poll(iomgr->aiop_poll_table, nfds, timeout_ms);
+ int res = poll(iomgr->full_poll_table, nfds, timeout_ms);
debugTrace(DEBUG_iomanager,
"poll(nfds = %d, timeout_ms = %d) = %d",
@@ -462,7 +502,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
} else if (res > 0) {
int ncompletions = res;
ASSERT(ncompletions <= (int)nfds);
- processIOCompletions(iomgr, ncompletions);
+ 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.
@@ -490,7 +530,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
}
} while (emptyRunQueue(iomgr->cap)
+ && !interrupt
&& (getSchedState() == SCHED_RUNNING));
+ return !interrupt;
}
static void reportPollError(int res, nfds_t nfds)
@@ -509,6 +551,12 @@ static void reportPollError(int res, nfds_t nfds)
}
+void interruptIOManagerPoll(CapIOManager *iomgr)
+{
+ sendFdWakeup(iomgr->interrupt_fd_w);
+}
+
+
/* Helper function to double the size of the aiop_table and aiop_poll_table.
*/
static bool enlargeTables(CapIOManager *iomgr)
@@ -519,13 +567,17 @@ static bool enlargeTables(CapIOManager *iomgr)
bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity);
if (RTS_UNLIKELY(!ok)) return false;
- /* Update the auxiliary aiop_poll_table to match */
- struct pollfd *aiop_poll_table;
- aiop_poll_table = stgReallocBytes(iomgr->aiop_poll_table,
- sizeof(struct pollfd) * newcapacity,
- "Poll.c: enlargeTables");
- iomgr->aiop_poll_table = aiop_poll_table;
+ /* Update the auxiliary aiop_poll_table to match. The full_poll_table is
+ * one bigger than the aiop_poll_table, since it has an extra entry at the
+ * front for interrupt_fd_r, with no corresponding aiop. */
+ iomgr->full_poll_table =
+ stgReallocBytes(iomgr->full_poll_table,
+ sizeof(struct pollfd) * (newcapacity+1),
+ "Poll.c: enlargeTables");
+ iomgr->aiop_poll_table = iomgr->full_poll_table+1;
+
/* Initialise the new part of the aiop_poll_table */
+ struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
for (int i = oldcapacity; i < newcapacity; i++) {
aiop_poll_table[i] = (struct pollfd) {
.fd = -1,
=====================================
rts/posix/Poll.h
=====================================
@@ -32,7 +32,8 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop);
/* Scheduler operations */
bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr);
void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
-void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr);
+void interruptIOManagerPoll(CapIOManager *iomgr);
#endif /* IOMGR_ENABLED_POLL */
=====================================
rts/posix/Select.c
=====================================
@@ -22,6 +22,7 @@
#include "IOManagerInternals.h"
#include "Stats.h"
#include "GetTime.h"
+#include "FdWakeup.h"
# if defined(HAVE_SYS_SELECT_H)
# include <sys/select.h>
@@ -54,6 +55,25 @@
#define TimeToLowResTimeRoundUp(t) (t)
#endif
+void initCapabilityIOManagerSelect(CapIOManager *iomgr)
+{
+ iomgr->blocked_queue_hd = END_TSO_QUEUE;
+ iomgr->blocked_queue_tl = END_TSO_QUEUE;
+ iomgr->sleeping_queue = END_TSO_QUEUE;
+
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+}
+
+void freeCapabilityIOManagerSelect(CapIOManager *iomgr)
+{
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
+}
+
+void interruptIOManagerSelect(CapIOManager *iomgr)
+{
+ sendFdWakeup(iomgr->interrupt_fd_w);
+}
+
/*
* Return the time since the program started, in LowResTime,
* rounded down.
@@ -215,7 +235,7 @@ static enum FdState fdPollWriteState (int fd)
* not write handles.
*
*/
-void
+bool
awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
{
StgTSO *tso, *prev, *next;
@@ -225,6 +245,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
bool seen_bad_fd = false;
struct timeval tv, *ptv;
LowResTime now;
+ bool interrupt = false; /* got interrupted up via interruptIOManager */
IF_DEBUG(scheduler,
debugBelch("scheduler: checking for threads blocked on I/O");
@@ -243,7 +264,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
now = getLowResTimeOfDay();
if (wakeUpSleepingThreads(iomgr, now)) {
- return;
+ return true;
}
/*
@@ -252,6 +273,13 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
FD_ZERO(&rfd);
FD_ZERO(&wfd);
+ /* We're always interested in our interrupt fd */
+ {
+ int fd = iomgr->interrupt_fd_r;
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ FD_SET(fd, &rfd);
+ }
+
for(tso = iomgr->blocked_queue_hd;
tso != END_TSO_QUEUE;
tso = next) {
@@ -354,14 +382,14 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
#if defined(RTS_USER_SIGNALS)
if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) {
startSignalHandlers(iomgr->cap);
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
#endif
/* we were interrupted, return to the scheduler immediately.
*/
if (getSchedState() >= SCHED_INTERRUPTING) {
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
/* check for threads that need waking up
@@ -372,10 +400,17 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
* I/O and run them.
*/
if (!emptyRunQueue(iomgr->cap)) {
- return; /* still hold the lock */
+ return true; /* still hold the lock */
}
}
+ /* If the interrupt_fd_r is ready, collect it */
+ if (FD_ISSET(iomgr->interrupt_fd_r, &rfd)) {
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in select I/O manager");
+ }
+
/* Step through the waiting queue, unblocking every thread that now has
* a file descriptor in a ready state.
*/
@@ -458,7 +493,9 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
}
} while (wait && getSchedState() == SCHED_RUNNING
- && emptyRunQueue(iomgr->cap));
+ && emptyRunQueue(iomgr->cap)
+ && !interrupt);
+ return !interrupt;
}
#endif /* IOMGR_ENABLED_SELECT */
=====================================
rts/posix/Select.h
=====================================
@@ -15,7 +15,12 @@ typedef StgWord LowResTime;
LowResTime getDelayTarget (HsInt us);
-void awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait);
+void initCapabilityIOManagerSelect(CapIOManager *iomgr);
+void freeCapabilityIOManagerSelect(CapIOManager *iomgr);
+void wakeupIOManagerSelect(CapIOManager *iomgr);
+
+bool awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait);
+void interruptIOManagerSelect(CapIOManager *iomgr);
#include "EndPrivate.h"
=====================================
rts/win32/AsyncMIO.c
=====================================
@@ -221,8 +221,12 @@ shutdownAsyncIO(bool wait_threads)
* requests to make further progress. In the latter scenario,
* awaitRequests() will simply block waiting for worker threads
* to complete if the 'completedTable' is empty.
+ *
+ * The result reports if the wait completed successfully (typically with some
+ * work available), or was interrupted by abandonRequestWait(), with true
+ * meaning completed, and false meaning interrupted.
*/
-int
+bool
awaitRequests(bool wait)
{
#if !defined(THREADED_RTS)
@@ -246,7 +250,7 @@ start:
#endif
) {
OS_RELEASE_LOCK(&queue_lock);
- return 0;
+ return true;
}
if (completed_hw == 0) {
// empty table, drop lock and wait
@@ -259,22 +263,24 @@ start:
// a request was completed
break;
case WAIT_OBJECT_0 + 1:
+ // abandon_req_wait signaled, by abandonRequestWait()
+ return false;
case WAIT_TIMEOUT:
// timeout (unlikely) or told to abandon waiting
- return 0;
+ return true;
case WAIT_FAILED: {
DWORD dw = GetLastError();
fprintf(stderr, "awaitRequests: wait failed -- "
"error code: %lu\n", dw); fflush(stderr);
- return 0;
+ return true;
}
default:
fprintf(stderr, "awaitRequests: unexpected wait return "
"code %lu\n", dwRes); fflush(stderr);
- return 0;
+ return true;
}
} else {
- return 0;
+ return true;
}
goto start;
} else {
@@ -352,7 +358,7 @@ start:
completed_hw = 0;
ResetEvent(completed_req_event);
OS_RELEASE_LOCK(&queue_lock);
- return 1;
+ return true;
}
#endif /* !THREADED_RTS */
}
@@ -383,12 +389,6 @@ abandonRequestWait( void )
interruptIOManagerEvent ();
}
-void
-resetAbandonRequestWait( void )
-{
- ResetEvent(abandon_req_wait);
-}
-
#endif /* !defined(THREADED_RTS) */
HsInt rts_EINTR(void)
=====================================
rts/win32/AsyncMIO.h
=====================================
@@ -25,7 +25,7 @@ extern unsigned int addDoProcRequest(void* proc, void* param);
extern int startupAsyncIO(void);
extern void shutdownAsyncIO(bool wait_threads);
-extern int awaitRequests(bool wait);
+extern bool awaitRequests(bool wait);
extern void abandonRequestWait(void);
extern void resetAbandonRequestWait(void);
=====================================
rts/win32/AwaitEvent.c
=====================================
@@ -28,17 +28,21 @@
// Protected by sched_mutex.
static bool workerWaitingForRequests = false;
-void
+bool
awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
{
+ bool interrupt = false;
do {
/* Try to de-queue completed IO requests
*/
workerWaitingForRequests = true;
if (is_io_mng_native_p())
awaitAsyncRequests(wait);
+ /* FIXME: no support yet for interrupting in WinIO I/O manager
+ * See issue #27403
+ */
else
- awaitRequests(wait);
+ interrupt = !awaitRequests(wait);
workerWaitingForRequests = false;
// If a signal was raised, we need to service it
@@ -47,11 +51,12 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
// does it and I'm feeling too paranoid to refactor it today --SDM
if (stg_pending_events != 0) {
startSignalHandlers(cap);
- return;
+ // This will normally cause emptyRunQueue to become false and
+ // thus we will drop out of the loop.
}
- // The return value from awaitRequests() is a red herring: ignore
- // it. Return to the scheduler if !wait, or
+ // The return value from awaitRequests() reports if it was interrupted by
+ // abandonRequestWait(). Return to the scheduler if !wait, or
//
// - we were interrupted
// - the run-queue is now non- empty
@@ -59,6 +64,8 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait)
} while (wait
&& getSchedState() == SCHED_RUNNING
&& emptyRunQueue(cap)
+ && !interrupt
);
+ return !interrupt;
}
#endif
=====================================
rts/win32/AwaitEvent.h
=====================================
@@ -2,6 +2,6 @@
#include "BeginPrivate.h"
-void awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait);
+bool awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait);
#include "EndPrivate.h"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c98f8fdbd59101887518a30a5a736e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c98f8fdbd59101887518a30a5a736e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] 2 commits: FIXUP Add interruptIOManager support for win32 legacy I/O manager
by Duncan Coutts (＠dcoutts) 18 Jun '26
by Duncan Coutts (＠dcoutts) 18 Jun '26
18 Jun '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC
Commits:
1fb92614 by Duncan Coutts at 2026-06-18T23:54:29+01:00
FIXUP Add interruptIOManager support for win32 legacy I/O manager
- - - - -
c98f8fdb by Duncan Coutts at 2026-06-18T23:55:21+01:00
FIXUP Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd
- - - - -
4 changed files:
- libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
- libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
- rts/win32/AsyncMIO.h
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Internal.Show (Show)
import GHC.Internal.Types (Bool(..), Int, IO)
import GHC.Internal.Word (Word8)
import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)
-import GHC.Internal.Foreign.C.Types (CInt(..), CSize(..))
+import GHC.Internal.Foreign.C.Types (CSize(..))
import GHC.Internal.Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import GHC.Internal.Foreign.Marshal.Alloc (alloca, allocaBytes)
import GHC.Internal.Foreign.Marshal.Array (allocaArray)
@@ -94,8 +94,8 @@ wakeupReadFd = controlEventFd
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
-newControl :: Bool -> IO Control
-newControl shouldRegister = allocaArray 2 $ \fds -> do
+newControl :: IO Control
+newControl = allocaArray 2 $ \fds -> do
let createPipe = do
throwErrnoIfMinus1_ "pipe" $ c_pipe fds
rd <- peekElemOff fds 0
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs
=====================================
@@ -194,7 +194,7 @@ newWith :: Backend -> IO EventManager
newWith be = do
iofds <- fmap (listArray (0, callbackArraySize-1)) $
replicateM callbackArraySize (newMVar =<< IT.new 8)
- ctrl <- newControl False
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
=====================================
@@ -126,7 +126,7 @@ new = newWith =<< newDefaultBackend
newWith :: Backend -> IO TimerManager
newWith be = do
timeouts <- newIORef Q.empty
- ctrl <- newControl True
+ ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
=====================================
rts/win32/AsyncMIO.h
=====================================
@@ -25,7 +25,7 @@ extern unsigned int addDoProcRequest(void* proc, void* param);
extern int startupAsyncIO(void);
extern void shutdownAsyncIO(bool wait_threads);
-extern int awaitRequests(bool wait);
+extern bool awaitRequests(bool wait);
extern void abandonRequestWait(void);
extern void resetAbandonRequestWait(void);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b105ca9f0a64891c04770fdf6cc7f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b105ca9f0a64891c04770fdf6cc7f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 9 commits: EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
by Alan Zimmerman (＠alanz) 18 Jun '26
by Alan Zimmerman (＠alanz) 18 Jun '26
18 Jun '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
54b9a5cf by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
This is part of a refactor towards only having LocatedA / SrcSpanAnnA
It removes the stated items, but has to add back one for BooleanFormula,
LocatedBF / SrcSpanAnnBF
This commit also use the HsConDetails RecCon extension point to
capture the braces in a record constructor
- - - - -
776c88ef by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedC / SrcSpanAnnC
Used for contexts
- - - - -
8f1c6b2b by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Harmonise HsQual/HsQualTy TTG extension annotations
- - - - -
efbbef72 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA Remove LocatedLC / LocatedLS
LocatedLC/LocatedLS were unused
- - - - -
4e34d0c0 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedLW from LStmtLR
- - - - -
2d681478 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedLW from MatchGroup
This is the last usage of LocatedLW / SrcSpanAnnLW
- - - - -
d773b871 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Move the 'where' annotation for PatSynBind
This allows us to move it out of the MatchGroup exact print annotation
too
- - - - -
b92ee0df by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Replace AnnListItem with simply [TrailingAnn]
Remove the unnecessary wrapper around a single field.
- - - - -
fb1f5a2d by Alan Zimmerman at 2026-06-18T23:22:04+01:00
Keep binds and sigs together in HsValBindsLR
TBD
- - - - -
94 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Type.hs
- ghc/GHCi/UI.hs
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15279.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/typecheck/should_compile/T15242.stderr
- testsuite/tests/typecheck/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/342e27cee9a1655316dcaf2e804448…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/342e27cee9a1655316dcaf2e804448…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/epa-tidy-locatedxxx-1] EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
by Alan Zimmerman (＠alanz) 18 Jun '26
by Alan Zimmerman (＠alanz) 18 Jun '26
18 Jun '26
Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-1 at Glasgow Haskell Compiler / GHC
Commits:
54b9a5cf by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
This is part of a refactor towards only having LocatedA / SrcSpanAnnA
It removes the stated items, but has to add back one for BooleanFormula,
LocatedBF / SrcSpanAnnBF
This commit also use the HsConDetails RecCon extension point to
capture the braces in a record constructor
- - - - -
61 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- ghc/GHCi/UI.hs
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54b9a5cf19e79f9b089846b626a9d49…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54b9a5cf19e79f9b089846b626a9d49…
You're receiving this email because of your account on gitlab.haskell.org.
1
0