[Git][ghc/ghc][wip/T26834] 6 commits: Refine import of Conc.IO
Teo Camarasu pushed to branch wip/T26834 at Glasgow Haskell Compiler / GHC Commits: ce4b8e28 by Teo Camarasu at 2026-01-31T11:56:52+00:00 Refine import of Conc.IO - - - - - 2d986e7c by Teo Camarasu at 2026-01-31T12:09:47+00:00 Move IO instance into MonadFix Revert "Move MonadFix instance of Q into MonadFix" This reverts commit e14fec2ddd5f3896a71aa9cbfb427523e8f6cdb2. - - - - - 49ef6c22 by Teo Camarasu at 2026-01-31T12:29:07+00:00 Avoid depending on Conc.Sync for re-exports - - - - - 77e0944d by Teo Camarasu at 2026-01-31T12:55:52+00:00 Invert some Read instances - - - - - d016d9c3 by Teo Camarasu at 2026-01-31T12:57:24+00:00 Explicit import - - - - - 52a9e6a0 by Teo Camarasu at 2026-01-31T13:09:21+00:00 HMMM Don't import Signal? - - - - - 18 changed files: - libraries/base/src/Control/Exception.hs - libraries/base/src/Control/Exception/Base.hs - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs Changes: ===================================== libraries/base/src/Control/Exception.hs ===================================== @@ -124,6 +124,7 @@ module Control.Exception import GHC.Internal.Control.Exception import GHC.Internal.Exception.Type +import GHC.Internal.Conc.Sync {- $catching ===================================== libraries/base/src/Control/Exception/Base.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -91,3 +91,4 @@ module Control.Exception.Base ) where import GHC.Internal.Control.Exception.Base +import GHC.Internal.Conc.Sync (throwTo) ===================================== libraries/base/src/System/IO.hs ===================================== @@ -185,6 +185,7 @@ module System.IO ) where import GHC.Internal.System.IO +import GHC.Internal.Control.Monad.Fix (fixIO) -- $locking -- Implementations should enforce as far as possible, at least locally to the ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs ===================================== @@ -66,6 +66,7 @@ import GHC.Internal.Foreign.C.Types import GHC.Internal.Control.Monad.Fail import GHC.Internal.Data.Either import qualified GHC.Internal.Control.Exception.Base as Exception +import qualified GHC.Internal.Conc.Sync as Exception import GHC.Internal.Base import GHC.Internal.Conc.Sync import GHC.Internal.IO ===================================== libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc ===================================== @@ -48,7 +48,7 @@ import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Stable -import GHC.Internal.Conc.IO +import GHC.Internal.Event.Thread import GHC.Internal.Control.Concurrent.MVar data Handler ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs ===================================== @@ -64,7 +64,6 @@ module GHC.Internal.Control.Exception ( throwIO, rethrowIO, ioError, - throwTo, -- ** The @catch@ functions catch, ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -49,7 +49,6 @@ module GHC.Internal.Control.Exception.Base ( rethrowIO, throw, ioError, - throwTo, -- * Catching Exceptions @@ -118,7 +117,6 @@ import GHC.Internal.IO.Exception import GHC.Internal.Exception.Type import GHC.Internal.Show -- import GHC.Internal.Exception hiding ( Exception ) -import GHC.Internal.Conc.Sync import GHC.Internal.Data.Either ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs ===================================== @@ -24,7 +24,8 @@ module GHC.Internal.Control.Monad.Fix ( MonadFix(mfix), - fix + fix, + fixIO ) where import GHC.Internal.Data.Either @@ -34,12 +35,15 @@ import GHC.Internal.Data.Monoid ( Monoid, Dual(..), Sum(..), Product(..) , First(..), Last(..), Alt(..), Ap(..) ) import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) import GHC.Internal.Data.Tuple ( Solo(..), snd ) -import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.) ) +import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.), return ) import GHC.Internal.List ( head, drop ) import GHC.Internal.Control.Monad.ST -import GHC.Internal.System.IO import GHC.Internal.Data.Functor.Identity (Identity(..)) import GHC.Internal.Generics +import GHC.Internal.IO +import GHC.Internal.IO.Exception +import GHC.Internal.IO.Unsafe () +import GHC.Internal.MVar -- | Monads having fixed points with a \'knot-tying\' semantics. -- Instances of 'MonadFix' should satisfy the following laws: @@ -98,6 +102,86 @@ instance MonadFix NonEmpty where neHead ~(a :| _) = a neTail ~(_ :| as) = as +-- --------------------------------------------------------------------------- +-- fixIO + +-- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'. +-- +-- This operation may fail with: +-- +-- * 'FixIOException' if the function passed to 'fixIO' inspects its argument. +-- +-- ==== __Examples__ +-- +-- the IO-action is only executed once. The recursion is only on the values. +-- +-- >>> take 3 <$> fixIO (\x -> putStr ":D" >> (:x) <$> readLn @Int) +-- :D +-- 2 +-- [2,2,2] +-- +-- If we are strict in the value, just as with 'Data.Function.fix', we do not get termination: +-- +-- >>> fixIO (\x -> putStr x >> pure ('x' : x)) +-- * hangs forever * +-- +-- We can tie the knot of a structure within 'IO' using 'fixIO': +-- +-- @ +-- data Node = MkNode Int (IORef Node) +-- +-- foo :: IO () +-- foo = do +-- p \<- fixIO (\p -> newIORef (MkNode 0 p)) +-- q <- output p +-- r <- output q +-- _ <- output r +-- pure () +-- +-- output :: IORef Node -> IO (IORef Node) +-- output ref = do +-- MkNode x p <- readIORef ref +-- print x +-- pure p +-- @ +-- +-- >>> foo +-- 0 +-- 0 +-- 0 +fixIO :: (a -> IO a) -> IO a +fixIO k = do + m <- newEmptyMVar + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO FixIOException) + result <- k ans + putMVar m result + return result + +-- Note [Blackholing in fixIO] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We do our own explicit black holing here, because GHC's lazy +-- blackholing isn't enough. In an infinite loop, GHC may run the IO +-- computation a few times before it notices the loop, which is wrong. +-- +-- NOTE2: the explicit black-holing with an IORef ran into trouble +-- with multiple threads (see #5421), so now we use an MVar. We used +-- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#, +-- which is not particularly cheap. Better to use readMVar, which can be +-- performed in multiple threads safely, and to use unsafeDupableInterleaveIO +-- to avoid the noDuplicate cost. +-- +-- What we'd ideally want is probably an IVar, but we don't quite have those. +-- STM TVars look like an option at first, but I don't think they are: +-- we'd need to be able to write to the variable in an IO context, which can +-- only be done using 'atomically', and 'atomically' is not allowed within +-- unsafePerformIO. We can't know if someone will try to use the result +-- of fixIO with unsafePerformIO! +-- +-- See also System.IO.Unsafe.unsafeFixIO. +-- + -- | @since base-2.01 instance MonadFix IO where mfix = fixIO ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Either.hs ===================================== @@ -34,7 +34,6 @@ module GHC.Internal.Data.Either ( import GHC.Internal.Base import GHC.Internal.Show -import GHC.Internal.Read -- $setup -- Allow the use of some Prelude functions in doctests. @@ -127,7 +126,6 @@ Left "parse error" data Either a b = Left a | Right b deriving ( Eq -- ^ @since base-2.01 , Ord -- ^ @since base-2.01 - , Read -- ^ @since base-3.0 , Show -- ^ @since base-3.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Internal.Data.Proxy import GHC.Internal.Base import GHC.Internal.Show -import GHC.Internal.Read import GHC.Internal.Enum import GHC.Internal.Arr @@ -54,7 +53,6 @@ import GHC.Internal.Arr -- >>> Proxy :: Proxy complicatedStructure -- Proxy data Proxy t = Proxy deriving ( Bounded -- ^ @since base-4.7.0.0 - , Read -- ^ @since base-4.7.0.0 ) -- | A concrete, promotable proxy type, for use at the kind level. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs ===================================== @@ -36,7 +36,6 @@ import qualified GHC.Internal.Data.Type.Equality as Eq import GHC.Internal.Data.Maybe import GHC.Internal.Enum import GHC.Internal.Show -import GHC.Internal.Read import GHC.Internal.Base -- | Representational equality. If @Coercion a b@ is inhabited by some terminating @@ -84,9 +83,6 @@ deriving instance Show (Coercion a b) -- | @since base-4.7.0.0 deriving instance Ord (Coercion a b) --- | @since base-4.7.0.0 -deriving instance Coercible a b => Read (Coercion a b) - -- | @since base-4.7.0.0 instance Coercible a b => Enum (Coercion a b) where toEnum 0 = Coercion ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs ===================================== @@ -49,7 +49,6 @@ module GHC.Internal.Data.Type.Equality ( import GHC.Internal.Data.Maybe import GHC.Internal.Enum import GHC.Internal.Show -import GHC.Internal.Read import GHC.Internal.Base import GHC.Internal.Data.Type.Bool @@ -105,9 +104,6 @@ deriving instance Show (a :~: b) -- | @since base-4.7.0.0 deriving instance Ord (a :~: b) --- | @since base-4.7.0.0 -deriving instance a ~ b => Read (a :~: b) - -- | @since base-4.7.0.0 instance a ~ b => Enum (a :~: b) where toEnum 0 = Refl @@ -133,9 +129,6 @@ deriving instance Show (a :~~: b) -- | @since base-4.10.0.0 deriving instance Ord (a :~~: b) --- | @since base-4.10.0.0 -deriving instance a ~~ b => Read (a :~~: b) - -- | @since base-4.10.0.0 instance a ~~ b => Enum (a :~~: b) where toEnum 0 = HRefl ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Control.hs ===================================== @@ -8,8 +8,7 @@ module GHC.Internal.Event.Control ( -- * Managing the IO manager - Signal - , ControlMessage(..) + ControlMessage(..) , Control , newControl , closeControl @@ -31,7 +30,6 @@ module GHC.Internal.Event.Control import GHC.Internal.Base import GHC.Internal.IORef -import GHC.Internal.Conc.Signal (Signal) import GHC.Internal.Real (fromIntegral) import GHC.Internal.Show (Show) import GHC.Internal.Word (Word8) @@ -56,7 +54,7 @@ import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF) data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Signal + {-# UNPACK #-} !CInt -- type Signal = CInt deriving ( Eq -- ^ @since base-4.4.0.0 , Show -- ^ @since base-4.4.0.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Device.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Internal.Read import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Num -import GHC.Internal.IO +import GHC.Internal.IO (throwIO) import {-# SOURCE #-} GHC.Internal.IO.Exception ( unsupportedOperation ) -- | A low-level I/O provider where the data is bytes in memory. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/FD.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Internal.IO.Buffer import GHC.Internal.IO.BufferedIO import qualified GHC.Internal.IO.Device import GHC.Internal.IO.Device (SeekMode(..), IODeviceType(..)) -import GHC.Internal.Conc.IO +import GHC.Internal.Event.Thread import GHC.Internal.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Internal.Windows ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-} +{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables, TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -74,6 +74,10 @@ import GHC.Internal.Arr import GHC.Internal.Word import GHC.Internal.List (filter) import GHC.Internal.Tuple (Solo (..)) +import GHC.Internal.Data.Type.Equality +import GHC.Internal.Data.Type.Coercion +import GHC.Internal.Data.Either +import GHC.Internal.Data.Proxy -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -833,3 +837,20 @@ instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) }) readListPrec = readListPrecDefault readList = readListDefault + + +-- | @since base-4.7.0.0 +deriving instance a ~ b => Read (a :~: b) + +-- | @since base-4.10.0.0 +deriving instance a ~~ b => Read (a :~~: b) + +-- | @since base-4.7.0.0 +deriving instance Coercible a b => Read (Coercion a b) + + +-- | @since base-3.0 +deriving instance (Read a, Read b) => Read (Either a b) + +-- | @since base-4.7.0.0 +deriving instance Read (Proxy s) ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -20,7 +20,6 @@ module GHC.Internal.System.IO ( -- * The IO monad IO, - fixIO, -- * Files and handles @@ -258,7 +257,6 @@ import GHC.Internal.IO.Encoding import GHC.Internal.Text.Read import GHC.Internal.IO.StdHandles import GHC.Internal.Show -import GHC.Internal.MVar ----------------------------------------------------------------------------- -- Standard IO @@ -602,87 +600,6 @@ hReady h = hWaitForInput h 0 hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStrLn hdl . show - --- --------------------------------------------------------------------------- --- fixIO - --- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'. --- --- This operation may fail with: --- --- * 'FixIOException' if the function passed to 'fixIO' inspects its argument. --- --- ==== __Examples__ --- --- the IO-action is only executed once. The recursion is only on the values. --- --- >>> take 3 <$> fixIO (\x -> putStr ":D" >> (:x) <$> readLn @Int) --- :D --- 2 --- [2,2,2] --- --- If we are strict in the value, just as with 'Data.Function.fix', we do not get termination: --- --- >>> fixIO (\x -> putStr x >> pure ('x' : x)) --- * hangs forever * --- --- We can tie the knot of a structure within 'IO' using 'fixIO': --- --- @ --- data Node = MkNode Int (IORef Node) --- --- foo :: IO () --- foo = do --- p \<- fixIO (\p -> newIORef (MkNode 0 p)) --- q <- output p --- r <- output q --- _ <- output r --- pure () --- --- output :: IORef Node -> IO (IORef Node) --- output ref = do --- MkNode x p <- readIORef ref --- print x --- pure p --- @ --- --- >>> foo --- 0 --- 0 --- 0 -fixIO :: (a -> IO a) -> IO a -fixIO k = do - m <- newEmptyMVar - ans <- unsafeDupableInterleaveIO - (readMVar m `catch` \BlockedIndefinitelyOnMVar -> - throwIO FixIOException) - result <- k ans - putMVar m result - return result - --- Note [Blackholing in fixIO] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We do our own explicit black holing here, because GHC's lazy --- blackholing isn't enough. In an infinite loop, GHC may run the IO --- computation a few times before it notices the loop, which is wrong. --- --- NOTE2: the explicit black-holing with an IORef ran into trouble --- with multiple threads (see #5421), so now we use an MVar. We used --- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#, --- which is not particularly cheap. Better to use readMVar, which can be --- performed in multiple threads safely, and to use unsafeDupableInterleaveIO --- to avoid the noDuplicate cost. --- --- What we'd ideally want is probably an IVar, but we don't quite have those. --- STM TVars look like an option at first, but I don't think they are: --- we'd need to be able to write to the variable in an IO context, which can --- only be done using 'atomically', and 'atomically' is not allowed within --- unsafePerformIO. We can't know if someone will try to use the result --- of fixIO with unsafePerformIO! --- --- See also System.IO.Unsafe.unsafeFixIO. --- - -- | The function creates a temporary file in ReadWrite mode. -- The created file isn\'t deleted automatically, so you need to delete it manually. -- ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Internal.TopHandler ( #include "HsBaseConfig.h" import GHC.Internal.Control.Exception +import GHC.Internal.Conc.Sync (throwTo) import GHC.Internal.Data.Maybe import GHC.Internal.Foreign.C.Error View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e14fec2ddd5f3896a71aa9cbfb42752... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e14fec2ddd5f3896a71aa9cbfb42752... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Teo Camarasu (＠teo)