diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +# effectful-core-2.7.1.2 (2026-09-10) +* Make the library work with the JavaScript backend. +* Fix `runPureEff` values being permanently poisoned by an asynchronous + exception delivered to a thread that forces them (see + [#380](https://github.com/haskell-effectful/effectful/issues/380) for more + information). As a workaround, `runPureEff` now runs the computation in a + separate thread. + # effectful-core-2.7.1.1 (2026-08-24) * Fix a performance regression introduced in 2.7.0.0 that increased the per-operation overhead of dynamically dispatched effects. diff --git a/effectful-core.cabal b/effectful-core.cabal --- a/effectful-core.cabal +++ b/effectful-core.cabal @@ -1,7 +1,7 @@ cabal-version: 3.8 build-type: Simple name: effectful-core -version: 2.7.1.1 +version: 2.7.1.2 license: BSD-3-Clause license-file: LICENSE category: Control diff --git a/src/Effectful/Internal/Env.hs b/src/Effectful/Internal/Env.hs --- a/src/Effectful/Internal/Env.hs +++ b/src/Effectful/Internal/Env.hs @@ -266,7 +266,7 @@ -- 'undefinedVersion' to maintain the invariant that slots beyond -- the size of the storage never contain garbage (see the note on -- 'undefinedVersion'). - setPrimArray vs newSize (vs0size - newSize) undefinedVersion + fillPrimArray vs newSize (vs0size - newSize) undefinedVersion pure vs else pure vs1 es0size <- getSizeofSmallMutableArray es0 @@ -554,7 +554,7 @@ -- Fill the unused part of the versions array with 'undefinedVersion' to -- maintain the invariant that slots beyond the size of the storage never -- contain garbage (see the note on 'undefinedVersion'). - setPrimArray vs size (len - size) undefinedVersion + fillPrimArray vs size (len - size) undefinedVersion copyMutablePrimArray vs 0 vs0 0 size copySmallMutableArray es 0 es0 0 size copySmallMutableArray fs 0 fs0 0 size diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs --- a/src/Effectful/Internal/Monad.hs +++ b/src/Effectful/Internal/Monad.hs @@ -82,7 +82,7 @@ ) where import Control.Applicative -import Control.Concurrent (myThreadId) +import Control.Concurrent import Control.Exception qualified as E import Control.Monad import Control.Monad.Base @@ -96,7 +96,7 @@ import GHC.Exts (oneShot) import GHC.IO (IO(..)) import GHC.Stack -import System.IO.Unsafe (unsafeDupablePerformIO) +import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) import Effectful.Internal.Effect @@ -129,15 +129,32 @@ -- | Run a pure 'Eff' computation. -- -- For running computations with side effects see 'runEff'. +-- +-- /Note:/ the computation runs in a separate thread as a workaround for +-- [#380](https://github.com/haskell-effectful/effectful/issues/380). runPureEff :: HasCallStack => Eff '[] a -> a -runPureEff (Eff m) = - -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no - -- IO with side effects was performed (unless someone sneakily introduced side - -- effects with unsafeEff, but then all bets are off). - -- - -- Moreover, internals don't allocate any resources that require explicit - -- cleanup actions to run. - unsafeDupablePerformIO $ m =<< emptyEnv +runPureEff (Eff m) = do + -- unsafePerformIO is safe here since IOE was not on the stack, so no IO with + -- side effects was performed (unless someone sneakily introduced side effects + -- with unsafeEff, but then all bets are off). + unsafePerformIO $ do + mv <- newEmptyMVar + -- A thunk has no masking state, so a plain forkIO here would make the + -- worker inherit the masking state of whichever thread forces the thunk + -- first. Start the worker masked so that the try and the putMVar can't be + -- interrupted, and run the computation unmasked. + _ <- E.mask_ $ forkIOWithUnmask $ \unmask -> do + r <- E.try @E.SomeException . unmask $ m =<< emptyEnv + putMVar mv r + -- Need to use readMVar instead of takeMVar. Entering the suspended + -- computation doesn't blackhole it, so several threads can resume it at + -- the same time and each of them needs the result. + -- + -- The wait must not be wrapped in an exception handler that kills the + -- worker. A catch frame on this stack is exactly what the fork avoids, and + -- a thread that resumes the suspended computation later still needs the + -- worker to fill the MVar. + either E.throwIO pure =<< readMVar mv ---------------------------------------- -- Access to the internal representation diff --git a/src/Effectful/Internal/Utils.hs b/src/Effectful/Internal/Utils.hs --- a/src/Effectful/Internal/Utils.hs +++ b/src/Effectful/Internal/Utils.hs @@ -22,13 +22,19 @@ -- * Array capacity , growCapacity + + -- * Utils for 'MutablePrimArray' + , fillPrimArray ) where import Control.Exception +import Control.Monad.Primitive import Data.Primitive.ByteArray +import Data.Primitive.PrimArray +import Data.Primitive.Types import Data.Word import GHC.Conc.Sync (ThreadId(..)) -import GHC.Exts (Any, RealWorld) +import GHC.Exts (Any) import GHC.Stack.Types (CallStack(..)) import Unsafe.Coerce (unsafeCoerce) @@ -115,3 +121,31 @@ -- See https://archive.ph/Z2R8w. growCapacity :: Int -> Int growCapacity n = 1 + quot (n * 3) 2 + +---------------------------------------- + +-- | Fill a slice of a mutable primitive array with a value. +fillPrimArray + :: forall a m + . (Prim a, PrimMonad m) + => MutablePrimArray (PrimState m) a + -> Int + -- ^ Offset of the first element to fill. + -> Int + -- ^ Number of elements to fill. + -> a + -- ^ Value to write. + -> m () +#if defined(javascript_HOST_ARCH) +-- 'setPrimArray' calls a C memset helper of the primitive package. The +-- JavaScript backend does not generate wrappers for foreign imports, and +-- primitive ships no JavaScript sources, so the symbol is missing at run time. +fillPrimArray arr off n x = go (off + n - 1) + where + go :: Int -> m () + go i + | i >= off = writePrimArray arr i x >> go (i - 1) + | otherwise = pure () +#else +fillPrimArray = setPrimArray +#endif