Cheng Shao pushed to branch wip/wasm-ghci-file-server at Glasgow Haskell Compiler / GHC Commits: 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - 165eb54b by Cheng Shao at 2026-02-25T09:44:28+00:00 wasm: add /assets endpoint to serve user-specified assets This patch adds an `/assets` endpoint to the wasm dyld http server, so that users can also fetch assets from the same host with sensible default MIME types, without needing a separate http server for assets that also introduces CORS headaches: - A `-fghci-browser-assets-dir` driver flag is added to specify the assets root directory (defaults to `$PWD`) - The dyld http server fetches `mime-db` on demand and uses it as source of truth for mime types. Closes #26951. - - - - - 29 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - docs/users_guide/wasm.rst - libraries/base/src/Control/Arrow.hs - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/mdo/should_fail/mdofail006.stderr - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1489,7 +1489,9 @@ composeAName = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey firstAName = varQual gHC_INTERNAL_ARROW (fsLit "first") firstAIdKey appAName = varQual gHC_INTERNAL_ARROW (fsLit "app") appAIdKey choiceAName = varQual gHC_INTERNAL_ARROW (fsLit "|||") choiceAIdKey -loopAName = varQual gHC_INTERNAL_ARROW (fsLit "loop") loopAIdKey +-- This is defined in Monad.Fix to flatten the module hierarchy of `ghc-internal` +-- It is the only thing from Control.Arrow that requires MonadFix +loopAName = varQual gHC_INTERNAL_MONAD_FIX (fsLit "loop") loopAIdKey -- Monad comprehensions guardMName, mzipName :: Name ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -30,6 +30,7 @@ initInterpOpts dflags = do , interpBrowser = gopt Opt_GhciBrowser dflags , interpBrowserHost = ghciBrowserHost dflags , interpBrowserPort = ghciBrowserPort dflags + , interpBrowserAssetsDir = ghciBrowserAssetsDir dflags , interpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags , interpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags , interpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags @@ -43,4 +44,3 @@ initInterpOpts dflags = do , interpCcConfig = configureCc dflags , interpExecutableLinkOpts = initExecutableLinkOpts dflags Dynamic } - ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -426,6 +426,7 @@ data DynFlags = DynFlags { -- wasm ghci browser mode ghciBrowserHost :: !String, ghciBrowserPort :: !Int, + ghciBrowserAssetsDir :: !(Maybe FilePath), ghciBrowserPuppeteerLaunchOpts :: !(Maybe String), ghciBrowserPlaywrightBrowserType :: !(Maybe String), ghciBrowserPlaywrightLaunchOpts :: !(Maybe String), @@ -727,6 +728,7 @@ defaultDynFlags mySettings = ghciBrowserHost = "127.0.0.1", ghciBrowserPort = 0, + ghciBrowserAssetsDir = Nothing, ghciBrowserPuppeteerLaunchOpts = Nothing, ghciBrowserPlaywrightBrowserType = Nothing, ghciBrowserPlaywrightLaunchOpts = Nothing, ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1896,6 +1896,8 @@ dynamic_flags_deps = [ $ hasArg $ \f d -> d { ghciBrowserHost = f } , make_ord_flag defGhciFlag "fghci-browser-port" $ intSuffix $ \n d -> d { ghciBrowserPort = n } + , make_ord_flag defGhciFlag "fghci-browser-assets-dir" + $ hasArg $ \f d -> d { ghciBrowserAssetsDir = Just f } , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts" $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f } , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type" ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -49,6 +49,7 @@ data InterpOpts = InterpOpts , interpBrowser :: Bool , interpBrowserHost :: String , interpBrowserPort :: Int + , interpBrowserAssetsDir :: !(Maybe FilePath) , interpBrowserRedirectWasiConsole :: Bool , interpBrowserPuppeteerLaunchOpts :: Maybe String , interpBrowserPlaywrightBrowserType :: Maybe String @@ -89,6 +90,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do , wasmInterpBrowser = interpBrowser opts , wasmInterpBrowserHost = interpBrowserHost opts , wasmInterpBrowserPort = interpBrowserPort opts + , wasmInterpBrowserAssetsDir = interpBrowserAssetsDir opts , wasmInterpBrowserRedirectWasiConsole = interpBrowserRedirectWasiConsole opts , wasmInterpBrowserPuppeteerLaunchOpts = interpBrowserPuppeteerLaunchOpts opts , wasmInterpBrowserPlaywrightBrowserType = interpBrowserPlaywrightBrowserType opts ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -220,6 +220,7 @@ data WasmInterpConfig = WasmInterpConfig , wasmInterpBrowser :: !Bool , wasmInterpBrowserHost :: !String , wasmInterpBrowserPort :: !Int + , wasmInterpBrowserAssetsDir :: !(Maybe FilePath) , wasmInterpBrowserRedirectWasiConsole :: !Bool , wasmInterpBrowserPuppeteerLaunchOpts :: !(Maybe String) , wasmInterpBrowserPlaywrightBrowserType :: !(Maybe String) ===================================== compiler/GHC/Runtime/Interpreter/Wasm.hs ===================================== @@ -52,6 +52,7 @@ spawnWasmInterp WasmInterpConfig {..} = do let dyld_env = [("GHCI_BROWSER", "1") | wasmInterpBrowser] ++ [("GHCI_BROWSER_HOST", wasmInterpBrowserHost), ("GHCI_BROWSER_PORT", show wasmInterpBrowserPort)] + ++ [("GHCI_BROWSER_ASSETS_DIR", f) | f <- maybeToList wasmInterpBrowserAssetsDir] ++ [("GHCI_BROWSER_REDIRECT_WASI_CONSOLE", "1") | wasmInterpBrowserRedirectWasiConsole] ++ [("GHCI_BROWSER_PUPPETEER_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPuppeteerLaunchOpts] ++ [("GHCI_BROWSER_PLAYWRIGHT_BROWSER_TYPE", f) | f <- maybeToList wasmInterpBrowserPlaywrightBrowserType] ===================================== docs/users_guide/wasm.rst ===================================== @@ -193,6 +193,18 @@ See below for other optional GHC flags of wasm ghci browser mode: Specify the port that the ``dyld`` HTTP server should listen on. Defaults to a random idle port. +.. ghc-flag:: -fghci-browser-assets-dir + :shortdesc: User-specified assets root directory + :type: dynamic + + :default: ``$PWD`` + + The HTTP server also exposes an ``/assets`` endpoint that allows + the users to fetch custom assets with sensible default MIME type, + e.g. `http://127.0.0.1:8080/assets/index.html` would fetch + `index.html` in the assets root directory with ``text/html`` MIME + type. + .. ghc-flag:: -fghci-browser-redirect-wasi-console :shortdesc: Redirect wasi console stdout/stderr back to host ghci. :type: dynamic ===================================== libraries/base/src/Control/Arrow.hs ===================================== @@ -50,3 +50,4 @@ module Control.Arrow ) where import GHC.Internal.Control.Arrow +import GHC.Internal.Control.Monad.Fix (ArrowLoop(..)) ===================================== 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/Control/Arrow.hs ===================================== @@ -45,13 +45,10 @@ module GHC.Internal.Control.Arrow ( ArrowChoice(..), -- * Arrow application ArrowApply(..), ArrowMonad(..), leftApp, - -- * Feedback - ArrowLoop(..) ) where -import GHC.Internal.Data.Tuple ( fst, snd, uncurry ) +import GHC.Internal.Data.Tuple ( uncurry ) import GHC.Internal.Data.Either -import GHC.Internal.Control.Monad.Fix import GHC.Internal.Control.Category import GHC.Internal.Base hiding ( (.), id ) import GHC.Internal.Generics (Generic, Generic1) @@ -419,55 +416,3 @@ leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d) leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) ||| (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app --- | The 'loop' operator expresses computations in which an output value --- is fed back as input, although the computation occurs only once. --- It underlies the @rec@ value recursion construct in arrow notation. --- 'loop' should satisfy the following laws: --- --- [/extension/] --- @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@ --- --- [/left tightening/] --- @'loop' ('first' h >>> f) = h >>> 'loop' f@ --- --- [/right tightening/] --- @'loop' (f >>> 'first' h) = 'loop' f >>> h@ --- --- [/sliding/] --- @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@ --- --- [/vanishing/] --- @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@ --- --- [/superposing/] --- @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@ --- --- where --- --- > assoc ((a,b),c) = (a,(b,c)) --- > unassoc (a,(b,c)) = ((a,b),c) --- -class Arrow a => ArrowLoop a where - -- | - -- - -- > ╭──────────────╮ - -- > b │ ╭───╮ │ c - -- > >───┼─────┤ ├────┼───> - -- > │ ┌─┤ ├─┐ │ - -- > │ d │ ╰───╯ │ │ - -- > │ └───<───┘ │ - -- > ╰──────────────╯ - loop :: a (b,d) (c,d) -> a b c - --- | @since base-2.01 -instance ArrowLoop (->) where - loop f b = let (c,d) = f (b,d) in c - --- | Beware that for many monads (those for which the '>>=' operation --- is strict) this instance will /not/ satisfy the right-tightening law --- required by the 'ArrowLoop' class. --- --- @since base-2.01 -instance MonadFix m => ArrowLoop (Kleisli m) where - loop (Kleisli f) = Kleisli (liftM fst . mfix . f') - where f' x y = f (x, snd y) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs ===================================== @@ -24,7 +24,10 @@ module GHC.Internal.Control.Monad.Fix ( MonadFix(mfix), - fix + fix, + fixIO, + -- * Feedback for Arrow + ArrowLoop(..) ) where import GHC.Internal.Data.Either @@ -34,12 +37,19 @@ import GHC.Internal.Data.Monoid ( Monoid, Dual(..), Sum(..), Product(..) , First(..), Last(..), Alt(..), Ap(..) ) import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) import GHC.Internal.Data.Ord ( Down(..) ) -import GHC.Internal.Data.Tuple ( Solo(..), snd ) -import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.) ) +import GHC.Internal.Data.Tuple ( Solo(..), fst, snd ) +import GHC.Internal.Base ( IO, Monad, errorWithoutStackTrace, (.), return, liftM ) import GHC.Internal.Generics import GHC.Internal.List ( head, drop ) import GHC.Internal.Control.Monad.ST.Imp -import GHC.Internal.System.IO +import qualified GHC.Internal.Control.Monad.ST.Lazy.Imp as Lazy +import GHC.Internal.Data.Functor.Identity (Identity(..)) +import GHC.Internal.MVar +import GHC.Internal.IO.Unsafe +import GHC.Internal.IO.Exception +import GHC.Internal.TH.Monad +import GHC.Internal.Control.Exception +import GHC.Internal.Control.Arrow -- | Monads having fixed points with a \'knot-tying\' semantics. -- Instances of 'MonadFix' should satisfy the following laws: @@ -102,6 +112,86 @@ instance MonadFix NonEmpty where instance MonadFix IO where mfix = fixIO +-- --------------------------------------------------------------------------- +-- 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 ((->) r) where mfix f = \ r -> let a = f a r in a @@ -116,6 +206,10 @@ instance MonadFix (Either e) where instance MonadFix (ST s) where mfix = fixST +-- | @since base-2.01 +instance MonadFix (Lazy.ST s) where + mfix = Lazy.fixST + -- Instances of Data.Monoid wrappers -- | @since base-4.8.0.0 @@ -171,3 +265,77 @@ instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where -- | @since base-4.12.0.0 instance MonadFix Down where mfix f = Down (fix (getDown . f)) + + +-- | @since base-4.8.0.0 +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) + +-- | If the function passed to 'mfix' inspects its argument, +-- the resulting action will throw a 'FixIOException'. +-- +-- @since 2.17.0.0 +instance MonadFix Q where + -- We use the same blackholing approach as in fixIO. + -- See Note [Blackholing in fixIO]. + mfix k = do + m <- runIO newEmptyMVar + ans <- runIO (unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO FixIOException)) + result <- k ans + runIO (putMVar m result) + return result + +-- | The 'loop' operator expresses computations in which an output value +-- is fed back as input, although the computation occurs only once. +-- It underlies the @rec@ value recursion construct in arrow notation. +-- 'loop' should satisfy the following laws: +-- +-- [/extension/] +-- @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@ +-- +-- [/left tightening/] +-- @'loop' ('first' h >>> f) = h >>> 'loop' f@ +-- +-- [/right tightening/] +-- @'loop' (f >>> 'first' h) = 'loop' f >>> h@ +-- +-- [/sliding/] +-- @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@ +-- +-- [/vanishing/] +-- @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@ +-- +-- [/superposing/] +-- @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@ +-- +-- where +-- +-- > assoc ((a,b),c) = (a,(b,c)) +-- > unassoc (a,(b,c)) = ((a,b),c) +-- +class Arrow a => ArrowLoop a where + -- | + -- + -- > ╭──────────────╮ + -- > b │ ╭───╮ │ c + -- > >───┼─────┤ ├────┼───> + -- > │ ┌─┤ ├─┐ │ + -- > │ d │ ╰───╯ │ │ + -- > │ └───<───┘ │ + -- > ╰──────────────╯ + loop :: a (b,d) (c,d) -> a b c + +-- | @since base-2.01 +instance ArrowLoop (->) where + loop f b = let (c,d) = f (b,d) in c + +-- | Beware that for many monads (those for which the '>>=' operation +-- is strict) this instance will /not/ satisfy the right-tightening law +-- required by the 'ArrowLoop' class. +-- +-- @since base-2.01 +instance MonadFix m => ArrowLoop (Kleisli m) where + loop (Kleisli f) = Kleisli (liftM fst . mfix . f') + where f' x y = f (x, snd y) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs ===================================== @@ -37,7 +37,6 @@ module GHC.Internal.Control.Monad.ST.Lazy.Imp ( unsafeIOToST ) where -import GHC.Internal.Control.Monad.Fix import GHC.Internal.Data.Tuple import qualified GHC.Internal.Control.Monad.ST.Imp as ST @@ -210,10 +209,6 @@ fixST m = ST (\ s -> -- itself is demanded directly in the `let` body. See also -- Note [Lazy ST: not producing lazy pairs]. --- | @since base-2.01 -instance MonadFix (ST s) where - mfix = fixST - -- | @since base-4.23.0.0 instance Semigroup a => Semigroup (ST s a) where (<>) = liftA2 (<>) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs ===================================== @@ -33,7 +33,6 @@ module GHC.Internal.Data.Functor.Identity ( Identity(..), ) where -import GHC.Internal.Control.Monad.Fix import GHC.Internal.Data.Bits (Bits, FiniteBits) import GHC.Internal.Data.Coerce import GHC.Internal.Data.Foldable @@ -143,7 +142,3 @@ instance Applicative Identity where -- | @since base-4.8.0.0 instance Monad Identity where m >>= k = k (runIdentity m) - --- | @since base-4.8.0.0 -instance MonadFix Identity where - mfix f = Identity (fix (runIdentity . f)) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Internal.Real (fromIntegral) import qualified GHC.Internal.Event.Array as A import GHC.Internal.IO.Handle.Internals (debugIO) import GHC.Internal.Conc.Sync (ThreadId(..)) -import GHC.Internal.RTS.Flags +import GHC.Internal.RTS.Flags.Test ------------------------------------------------------------------------ -- Thread spool manager @@ -60,7 +60,7 @@ startThreadPool job = do let thrMinThreads = 2 let thrCurThreads = 0 let thrCallBack = job - thrMaxThreads <- (fromIntegral . numIoWorkerThreads) `fmap` getMiscFlags + thrMaxThreads <- getNumIoWorkerThreads thrActiveThreads <- newMVar 0 thrMonitor <- newEmptyMVar thrThreadIds <- undefined -- A.new thrMaxThreads ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc ===================================== @@ -4,24 +4,23 @@ -- that allows to quickly test if some flag is set. module GHC.Internal.RTS.Flags.Test ( getUserEventTracingEnabled + , getNumIoWorkerThreads ) where import GHC.Internal.Base - -#if !defined(javascript_HOST_ARCH) - import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import GHC.Internal.Data.Functor ((<$>)) +import GHC.Internal.Word (Word32) +import GHC.Internal.Real (fromIntegral) #include "Rts.h" #include "rts/Flags.h" foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr () -#endif -- | Specialized version of 'getTraceFlags' for just checking if user -- event tracing is enabled. @@ -34,3 +33,9 @@ getUserEventTracingEnabled = do let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr toBool <$> (#{peek TRACE_FLAGS, user} ptr :: IO CBool) #endif + +-- | Specialized version of 'getMiscFlags' for just checking the number of IO worker threads +getNumIoWorkerThreads :: IO Int +getNumIoWorkerThreads = do + let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr + fromIntegral <$> (#{peek MISC_FLAGS, numIoWorkerThreads} ptr :: IO Word32) ===================================== 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/System/IO/OS.hs ===================================== @@ -23,7 +23,9 @@ module GHC.Internal.System.IO.OS ) where -import GHC.Internal.Base +#if defined(mingw32_HOST_OS) +import GHC.Internal.Base (otherwise) +#endif import GHC.Internal.Control.Monad (return) import GHC.Internal.Control.Concurrent.MVar (MVar) import GHC.Internal.Control.Exception (mask) ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -28,13 +28,8 @@ import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Fix (MonadFix (..)) -import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO) -import Control.Exception.Base (FixIOException (..)) -import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) import System.IO ( hPutStrLn, stderr ) import qualified Data.Kind as Kind (Type) -import GHC.IO.Unsafe ( unsafeDupableInterleaveIO ) import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) @@ -46,12 +41,8 @@ import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class import GHC.Internal.Control.Monad.Fail -import GHC.Internal.Control.Monad.Fix -import GHC.Internal.Control.Exception import GHC.Internal.Num import GHC.Internal.IO.Unsafe -import GHC.Internal.MVar -import GHC.Internal.IO.Exception import qualified GHC.Internal.Types as Kind (Type) #endif import GHC.Internal.ForeignSrcLang @@ -258,22 +249,6 @@ instance Semigroup a => Semigroup (Q a) where instance Monoid a => Monoid (Q a) where mempty = pure mempty --- | If the function passed to 'mfix' inspects its argument, --- the resulting action will throw a 'FixIOException'. --- --- @since 2.17.0.0 -instance MonadFix Q where - -- We use the same blackholing approach as in fixIO. - -- See Note [Blackholing in fixIO] in System.IO in base. - mfix k = do - m <- runIO newEmptyMVar - ans <- runIO (unsafeDupableInterleaveIO - (readMVar m `catch` \BlockedIndefinitelyOnMVar -> - throwIO FixIOException)) - result <- k ans - runIO (putMVar m result) - return result - ----------------------------------------------------- -- ===================================== testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout ===================================== @@ -41,10 +41,10 @@ data Tuple2 a b = (,) a b -- Defined in ‘GHC.Internal.Tuple’ instance Traversable (Tuple2 a) -- Defined in ‘GHC.Internal.Data.Traversable’ -instance Foldable (Tuple2 a) - -- Defined in ‘GHC.Internal.Data.Foldable’ instance Monoid a => Applicative (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ +instance Foldable (Tuple2 a) + -- Defined in ‘GHC.Internal.Data.Foldable’ instance Functor (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ instance Monoid a => Monad (Tuple2 a) -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/ghci/scripts/T10963.stderr ===================================== @@ -1,4 +1,3 @@ - <interactive>:1:1: error: [GHC-39999] • Ambiguous type variable ‘a0’ arising from a use of ‘foo’ prevents the constraint ‘(Num a0)’ from being solved. @@ -10,3 +9,4 @@ ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: foo + ===================================== testsuite/tests/ghci/scripts/T4175.stdout ===================================== @@ -44,8 +44,8 @@ instance Traversable Maybe -- Defined in ‘GHC.Internal.Data.Traversable’ instance MonadFail Maybe -- Defined in ‘GHC.Internal.Control.Monad.Fail’ -instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’ +instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’ instance Functor Maybe -- Defined in ‘GHC.Internal.Base’ instance Monad Maybe -- Defined in ‘GHC.Internal.Base’ instance Semigroup a => Monoid (Maybe a) ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11527,8 +11527,6 @@ instance GHC.Internal.Control.Arrow.ArrowApply (->) -- Defined in ‘GHC.Interna instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowApply (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance GHC.Internal.Control.Arrow.ArrowChoice (->) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowChoice (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance GHC.Internal.Control.Arrow.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Arrow.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowPlus (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowZero (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Category.Category (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ @@ -11544,6 +11542,8 @@ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fail.MonadFail f => GH instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.P -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.ReadP -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadPrec.ReadPrec -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadPrec’ +instance GHC.Internal.Control.Monad.Fix.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Monad.Fix.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Monoid.Ap f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11553,6 +11553,7 @@ instance forall e. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Ei instance forall r. GHC.Internal.Control.Monad.Fix.MonadFix ((->) r) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix [] -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11560,14 +11561,14 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Maybe.Maybe -- Def instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ -instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’ -instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.First -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -11554,8 +11554,6 @@ instance GHC.Internal.Control.Arrow.ArrowApply (->) -- Defined in ‘GHC.Interna instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowApply (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance GHC.Internal.Control.Arrow.ArrowChoice (->) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowChoice (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance GHC.Internal.Control.Arrow.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Arrow.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowPlus (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowZero (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Category.Category (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ @@ -11571,6 +11569,8 @@ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fail.MonadFail f => GH instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.P -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.ReadP -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadPrec.ReadPrec -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadPrec’ +instance GHC.Internal.Control.Monad.Fix.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Monad.Fix.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Monoid.Ap f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11580,6 +11580,7 @@ instance forall e. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Ei instance forall r. GHC.Internal.Control.Monad.Fix.MonadFix ((->) r) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix [] -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11587,14 +11588,14 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Maybe.Maybe -- Def instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ -instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’ -instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.First -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11785,8 +11785,6 @@ instance GHC.Internal.Control.Arrow.ArrowApply (->) -- Defined in ‘GHC.Interna instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowApply (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance GHC.Internal.Control.Arrow.ArrowChoice (->) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowChoice (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance GHC.Internal.Control.Arrow.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Arrow.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowPlus (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowZero (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Category.Category (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ @@ -11802,6 +11800,8 @@ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fail.MonadFail f => GH instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.P -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.ReadP -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadPrec.ReadPrec -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadPrec’ +instance GHC.Internal.Control.Monad.Fix.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Monad.Fix.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Monoid.Ap f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11811,6 +11811,7 @@ instance forall e. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Ei instance forall r. GHC.Internal.Control.Monad.Fix.MonadFix ((->) r) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix [] -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11818,14 +11819,14 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Maybe.Maybe -- Def instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ -instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’ -instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.First -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11527,8 +11527,6 @@ instance GHC.Internal.Control.Arrow.ArrowApply (->) -- Defined in ‘GHC.Interna instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowApply (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance GHC.Internal.Control.Arrow.ArrowChoice (->) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Arrow.ArrowChoice (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance GHC.Internal.Control.Arrow.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Arrow’ -instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Arrow.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowPlus (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.MonadPlus m => GHC.Internal.Control.Arrow.ArrowZero (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ instance forall (m :: * -> *). GHC.Internal.Base.Monad m => GHC.Internal.Control.Category.Category (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Arrow’ @@ -11544,6 +11542,8 @@ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fail.MonadFail f => GH instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.P -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadP.ReadP -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadP’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.Text.ParserCombinators.ReadPrec.ReadPrec -- Defined in ‘GHC.Internal.Text.ParserCombinators.ReadPrec’ +instance GHC.Internal.Control.Monad.Fix.ArrowLoop (->) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall (m :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix m => GHC.Internal.Control.Monad.Fix.ArrowLoop (GHC.Internal.Control.Arrow.Kleisli m) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Monoid.Ap f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11553,6 +11553,7 @@ instance forall e. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Data.Ei instance forall r. GHC.Internal.Control.Monad.Fix.MonadFix ((->) r) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix [] -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ @@ -11560,14 +11561,14 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Maybe.Maybe -- Def instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall (f :: * -> *). GHC.Internal.Control.Monad.Fix.MonadFix f => GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ +instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’ instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’ -instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’ -instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’ instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Fix.MonadFix f, GHC.Internal.Control.Monad.Fix.MonadFix g) => GHC.Internal.Control.Monad.Fix.MonadFix (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.First -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -2052,7 +2052,6 @@ instance GHC.Internal.Classes.Ord GHC.Internal.TH.Syntax.Type -- Defined in ‘G instance GHC.Internal.Classes.Ord GHC.Internal.TH.Syntax.TypeFamilyHead -- Defined in ‘GHC.Internal.TH.Syntax’ instance GHC.Internal.Classes.Ord GHC.Internal.LanguageExtensions.Extension -- Defined in ‘GHC.Internal.LanguageExtensions’ instance GHC.Internal.Control.Monad.Fail.MonadFail GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ -instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.Control.Monad.IO.Class.MonadIO GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.Data.Foldable.Foldable GHC.Internal.TH.Syntax.TyVarBndr -- Defined in ‘GHC.Internal.TH.Syntax’ instance GHC.Internal.Data.Traversable.Traversable GHC.Internal.TH.Syntax.TyVarBndr -- Defined in ‘GHC.Internal.TH.Syntax’ ===================================== testsuite/tests/mdo/should_fail/mdofail006.stderr ===================================== @@ -5,5 +5,5 @@ cyclic evaluation in fixIO While handling thread blocked indefinitely in an MVar operation HasCallStack backtrace: - throwIO, called at libraries/ghc-internal/src/GHC/Internal/System/IO.hs:641:37 in ghc-internal:GHC.Internal.System.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs:167:37 in ghc-internal:GHC.Internal.Control.Monad.Fix ===================================== utils/jsffi/dyld.mjs ===================================== @@ -560,6 +560,7 @@ export class DyLDRPC { // Actual implementation of endpoints used by DyLDRPC class DyLDRPCServer { + #mimeDb; #dyldHost; #server; #wss; @@ -567,6 +568,7 @@ class DyLDRPCServer { constructor({ host, port, + assetsDir, dyldPath, searchDirs, mainSoPath, @@ -575,6 +577,20 @@ class DyLDRPCServer { args, redirectWasiConsole, }) { + this.#mimeDb = fetch("https://cdn.jsdelivr.net/npm/mime-db@1.54.0/db.json") + .then((resp) => resp.json()) + .then((db) => { + const ext2mime = {}; + for (const mime in db) { + if (db[mime].extensions) { + for (const ext of db[mime].extensions) { + ext2mime[`.${ext}`] = mime; + } + } + } + return ext2mime; + }); + this.#dyldHost = new DyLDHost({ outFd, inFd }); this.#server = http.createServer(async (req, res) => { @@ -634,6 +650,30 @@ args.rpc.opened.then(() => main(args)); return; } + if (req.url.startsWith("/assets")) { + const p = path.resolve(assetsDir, req.url.replace("/assets/", "")); + try { + await fs.promises.access(p, fs.promises.constants.R_OK); + + res.setHeader( + "Content-Type", + (await this.#mimeDb)[path.extname(p)] || "application/octet-stream", + ); + + res.setHeader("Cache-Control", "no-cache, no-store, must-revalidate"); + + res.writeHead(200); + fs.createReadStream(p).pipe(res); + } catch { + res.writeHead(404, { + "Content-Type": "text/plain", + }); + res.end("not found"); + } + + return; + } + if (req.url.startsWith("/rpc")) { const endpoint = req.url.replace("/rpc/", ""); @@ -1373,6 +1413,7 @@ async function nodeMain({ searchDirs, mainSoPath, outFd, inFd, args }) { const server = new DyLDRPCServer({ host: process.env.GHCI_BROWSER_HOST || "127.0.0.1", port: process.env.GHCI_BROWSER_PORT || 0, + assetsDir: process.env.GHCI_BROWSER_ASSETS_DIR || process.cwd(), dyldPath: import.meta.filename, searchDirs, mainSoPath, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86d4a384f55c0cfddc82068e311b778... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86d4a384f55c0cfddc82068e311b778... You're receiving this email because of your account on gitlab.haskell.org.