From 1c60909a2b7a8f9372214a164ea7a8af8a600209 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Thu, 10 Oct 2024 00:51:38 +0200 Subject: [PATCH] Fix NonDet/OnEmptyRollback --- effectful-core/CHANGELOG.md | 5 + .../Effectful/Dispatch/Static/Primitive.hs | 1 - effectful-core/src/Effectful/Internal/Env.hs | 126 ++++++++++-------- .../src/Effectful/Internal/Monad.hs | 2 + effectful-core/src/Effectful/NonDet.hs | 35 ++--- effectful/CHANGELOG.md | 5 + effectful/tests/EnvTests.hs | 22 --- effectful/tests/StateTests.hs | 2 +- 8 files changed, 98 insertions(+), 100 deletions(-) diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 8273e94..abbd107 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -1,6 +1,11 @@ # effectful-core-2.5.0.0 (????-??-??) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make `emptyEff` and `sumEff` generate better call stacks. +* **Bugfixes**: + - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken. +* **Breaking changes**: + - Removed `restoreEnv` function from `Effectful.Dispatch.Static.Primitive` + since it was broken. # effectful-core-2.4.0.0 (2024-10-08) * Add utility functions for handling effects that take the effect handler as the diff --git a/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs b/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs index e6768a9..a08c0f7 100644 --- a/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs +++ b/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs @@ -31,7 +31,6 @@ module Effectful.Dispatch.Static.Primitive -- ** Utils , emptyEnv , cloneEnv - , restoreEnv , sizeEnv , tailEnv ) where diff --git a/effectful-core/src/Effectful/Internal/Env.hs b/effectful-core/src/Effectful/Internal/Env.hs index 2be5e5c..c157fb3 100644 --- a/effectful-core/src/Effectful/Internal/Env.hs +++ b/effectful-core/src/Effectful/Internal/Env.hs @@ -9,12 +9,19 @@ module Effectful.Internal.Env , Ref(..) , Version , Storage(..) - , AnyEffect - , toAnyEffect - , fromAnyEffect + + -- ** StorageData + , StorageData(..) + , copyStorageData + , restoreStorageData + + -- *** Utils , AnyRelinker , toAnyRelinker , fromAnyRelinker + , AnyEffect + , toAnyEffect + , fromAnyEffect -- ** Relinker , Relinker(..) @@ -29,7 +36,6 @@ module Effectful.Internal.Env -- * Operations , emptyEnv , cloneEnv - , restoreEnv , sizeEnv , tailEnv @@ -134,13 +140,13 @@ newtype Version = Version Int -- | A storage of effects. data Storage = Storage - { stSize :: !Int - , stVersion :: !Version - , stVersions :: !(MutablePrimArray RealWorld Version) - , stEffects :: !(SmallMutableArray RealWorld AnyEffect) - , stRelinkers :: !(SmallMutableArray RealWorld AnyRelinker) + { stVersion :: !Version + , stData :: {-# UNPACK #-} !StorageData } +---------------------------------------- +-- StorageData + -- | Effect in 'Storage'. newtype AnyEffect = AnyEffect Any @@ -159,6 +165,46 @@ toAnyRelinker = AnyRelinker . toAny fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e fromAnyRelinker (AnyRelinker f) = fromAny f +---------------------------------------- + +data StorageData = StorageData + { sdSize :: !Int + , sdVersions :: !(MutablePrimArray RealWorld Version) + , sdEffects :: !(SmallMutableArray RealWorld AnyEffect) + , sdRelinkers :: !(SmallMutableArray RealWorld AnyRelinker) + } + +-- | Make a shallow copy of the 'StorageData'. +-- +-- @since 2.5.0.0 +copyStorageData :: HasCallStack => StorageData -> IO StorageData +copyStorageData (StorageData storageSize vs0 es0 fs0) = do + vsSize <- getSizeofMutablePrimArray vs0 + esSize <- getSizeofSmallMutableArray es0 + fsSize <- getSizeofSmallMutableArray fs0 + when (vsSize /= esSize) $ do + error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")" + when (esSize /= fsSize) $ do + error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")" + vs <- cloneMutablePrimArray vs0 0 vsSize + es <- cloneSmallMutableArray es0 0 esSize + fs <- cloneSmallMutableArray fs0 0 fsSize + pure $ StorageData storageSize vs es fs + +-- | Restore a shallow copy of the 'StorageData'. +-- +-- The copy needs to be from the same 'Env' as the target. +-- +-- @since 2.5.0.0 +restoreStorageData :: HasCallStack => StorageData -> Env es -> IO () +restoreStorageData newStorageData env = do + modifyIORef' (envStorage env) $ \(Storage version oldStorageData) -> + let oldSize = sdSize oldStorageData + newSize = sdSize newStorageData + in if newSize /= oldSize + then error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")" + else Storage version newStorageData + ---------------------------------------- -- Relinker @@ -205,18 +251,9 @@ emptyEnv = Env 0 -- | Clone the environment to use it in a different thread. cloneEnv :: HasCallStack => Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do - Storage storageSize version vs0 es0 fs0 <- readIORef' storage0 - vsSize <- getSizeofMutablePrimArray vs0 - esSize <- getSizeofSmallMutableArray es0 - fsSize <- getSizeofSmallMutableArray fs0 - when (vsSize /= esSize) $ do - error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")" - when (esSize /= fsSize) $ do - error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")" - vs <- cloneMutablePrimArray vs0 0 vsSize - es <- cloneSmallMutableArray es0 0 esSize - fs <- cloneSmallMutableArray fs0 0 fsSize - storage <- newIORef' $ Storage storageSize version vs es fs + Storage version storageData0 <- readIORef' storage0 + storageData@(StorageData storageSize _ es fs) <- copyStorageData storageData0 + storage <- newIORef' $ Storage version storageData let relinkEffects = \case 0 -> pure () k -> do @@ -230,29 +267,6 @@ cloneEnv (Env offset refs storage0) = do pure $ Env offset refs storage {-# NOINLINE cloneEnv #-} --- | Restore the environment from its clone. --- --- @since 2.2.0.0 -restoreEnv - :: HasCallStack - => Env es -- ^ Destination. - -> Env es -- ^ Source. - -> IO () -restoreEnv dest src = do - destStorage <- readIORef' (envStorage dest) - srcStorage <- readIORef' (envStorage src) - let destStorageSize = stSize destStorage - srcStorageSize = stSize srcStorage - when (destStorageSize /= srcStorageSize) $ do - error $ "destStorageSize (" ++ show destStorageSize - ++ ") /= srcStorageSize (" ++ show srcStorageSize ++ ")" - writeIORef' (envStorage dest) $ srcStorage - -- Decreasing the counter allows leakage of unsafeCoerce (see unsafeCoerce2 - -- in the EnvTests module). - { stVersion = max (stVersion destStorage) (stVersion srcStorage) - } -{-# NOINLINE restoreEnv #-} - -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do @@ -413,7 +427,7 @@ getLocation => Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do - Storage _ _ vs es _ <- readIORef' storage + Storage _ (StorageData _ vs es _) <- readIORef' storage storageVersion <- readPrimArray vs ref -- If version of the reference is different than version in the storage, it -- means that the effect in the storage is not the one that was initially @@ -433,10 +447,12 @@ getLocation (Env offset refs storage) = do -- | Create an empty storage. emptyStorage :: HasCallStack => IO Storage -emptyStorage = Storage 0 initialVersion - <$> newPrimArray 0 - <*> newSmallArray 0 undefinedEffect - <*> newSmallArray 0 undefinedRelinker +emptyStorage = Storage initialVersion <$> storageData + where + storageData = StorageData 0 + <$> newPrimArray 0 + <*> newSmallArray 0 undefinedEffect + <*> newSmallArray 0 undefinedRelinker -- | Insert an effect into the storage and return its reference. insertEffect @@ -447,7 +463,7 @@ insertEffect -> Relinker (EffectRep (DispatchOf e)) e -> IO Ref insertEffect storage e f = do - Storage size version vs0 es0 fs0 <- readIORef' storage + Storage version (StorageData size vs0 es0 fs0) <- readIORef' storage len0 <- getSizeofSmallMutableArray es0 case size `compare` len0 of GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" @@ -455,7 +471,8 @@ insertEffect storage e f = do writePrimArray vs0 size version writeSmallArray' es0 size (toAnyEffect e) writeSmallArray' fs0 size (toAnyRelinker f) - writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs0 es0 fs0 + writeIORef' storage $ + Storage (bumpVersion version) (StorageData (size + 1) vs0 es0 fs0) pure $ Ref size version EQ -> do let len = doubleCapacity len0 @@ -468,14 +485,15 @@ insertEffect storage e f = do writePrimArray vs size version writeSmallArray' es size (toAnyEffect e) writeSmallArray' fs size (toAnyRelinker f) - writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs es fs + writeIORef' storage $ + Storage (bumpVersion version) (StorageData (size + 1) vs es fs) pure $ Ref size version -- | Given a reference to an effect from the top of the stack, delete it from -- the storage. deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO () deleteEffect storage (Ref ref version) = do - Storage size currentVersion vs es fs <- readIORef' storage + Storage currentVersion (StorageData size vs es fs) <- readIORef' storage when (ref /= size - 1) $ do error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")" storageVersion <- readPrimArray vs ref @@ -485,7 +503,7 @@ deleteEffect storage (Ref ref version) = do writePrimArray vs ref undefinedVersion writeSmallArray es ref undefinedEffect writeSmallArray fs ref undefinedRelinker - writeIORef' storage $ Storage (size - 1) currentVersion vs es fs + writeIORef' storage $ Storage currentVersion (StorageData (size - 1) vs es fs) -- | Relink the environment to use the new storage. relinkEnv :: IORef' Storage -> Env es -> IO (Env es) diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index 1ac5f79..2059262 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -553,6 +553,8 @@ send -> Eff es a send op = unsafeEff $ \es -> do Handler handlerEs handler <- getEnv es + when (envStorage es /= envStorage handlerEs) $ do + error "es and handlerEs point to different Storages" -- Prevent internal functions that rebind the effect handler from polluting -- its call stack by freezing it. Note that functions 'interpret', -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful diff --git a/effectful-core/src/Effectful/NonDet.hs b/effectful-core/src/Effectful/NonDet.hs index 5902026..dfe80c4 100644 --- a/effectful-core/src/Effectful/NonDet.hs +++ b/effectful-core/src/Effectful/NonDet.hs @@ -22,7 +22,7 @@ module Effectful.NonDet ) where import Control.Applicative -import Data.Coerce +import Data.IORef.Strict import GHC.Generics import GHC.Stack @@ -31,13 +31,14 @@ import Effectful.Dispatch.Dynamic import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive import Effectful.Error.Static -import Effectful.Internal.Monad (LocalEnv(..), NonDet(..)) +import Effectful.Internal.Env qualified as I +import Effectful.Internal.Monad (NonDet(..)) -- | Policy of dealing with modifications to __thread local__ state in the -- environment in branches that end up calling the 'Empty' operation. -- --- /Note:/ 'OnEmptyKeep' is significantly faster as there is no need to back up --- the environment on each call to ':<|>:'. +-- /Note:/ 'OnEmptyKeep' is faster as there is no need to back up the +-- environment on each call to ':<|>:'. -- -- @since 2.2.0.0 data OnEmptyPolicy @@ -84,23 +85,23 @@ runNonDetRollback runNonDetRollback = reinterpret setup $ \env -> \case Empty -> throwError ErrorEmpty m1 :<|>: m2 -> do - backupEnv <- cloneLocalEnv env + backupData <- unsafeEff backupStorageData localSeqUnlift env $ \unlift -> do mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do - -- If m1 failed, roll back the environment. - restoreLocalEnv env backupEnv + -- If m1 failed, restore the data. + unsafeEff $ I.restoreStorageData backupData pure Nothing case mr of Just r -> pure r Nothing -> unlift m2 where setup action = do - backupEs <- unsafeEff cloneEnv + backupData <- unsafeEff backupStorageData runError @ErrorEmpty action >>= \case Right r -> pure $ Right r Left (cs, _) -> do - -- If the whole action failed, roll back the environment. - unsafeEff $ \es -> restoreEnv es backupEs + -- If the whole action failed, restore the data. + unsafeEff $ I.restoreStorageData backupData pure $ Left cs ---------------------------------------- @@ -139,15 +140,5 @@ instance Show ErrorEmpty where noError :: Either (cs, e) a -> Either cs a noError = either (Left . fst) Right -cloneLocalEnv - :: HasCallStack - => LocalEnv localEs handlerEs - -> Eff es (LocalEnv localEs handlerEs) -cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce - -restoreLocalEnv - :: HasCallStack - => LocalEnv localEs handlerEs - -> LocalEnv localEs handlerEs - -> Eff es () -restoreLocalEnv dest src = unsafeEff_ $ restoreEnv (coerce dest) (coerce src) +backupStorageData :: HasCallStack => Env es -> IO I.StorageData +backupStorageData env = I.copyStorageData . I.stData =<< readIORef' (I.envStorage env) diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index 620c1d6..d8fc9a0 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -1,6 +1,11 @@ # effectful-2.5.0.0 (????-??-??) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make `emptyEff` and `sumEff` generate better call stacks. +* **Bugfixes**: + - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken. +* **Breaking changes**: + - Removed `restoreEnv` function from `Effectful.Dispatch.Static.Primitive` + since it was broken. # effectful-2.4.0.0 (2024-10-08) * Add utility functions for handling effects that take the effect handler as the diff --git a/effectful/tests/EnvTests.hs b/effectful/tests/EnvTests.hs index a1be74a..7a724f3 100644 --- a/effectful/tests/EnvTests.hs +++ b/effectful/tests/EnvTests.hs @@ -104,8 +104,6 @@ test_noUnsafeCoerce :: Assertion test_noUnsafeCoerce = do r1 <- try @ErrorCall . evaluate $ unsafeCoerce1 @Int 'a' assertBool "unsafeCoerce1" (isLeft r1) - r2 <- try @ErrorCall . evaluate $ unsafeCoerce2 @Int 'a' - assertBool "unsafeCoerce2" (isLeft r2) unsafeCoerce1 :: forall b a. a -> b unsafeCoerce1 a = runPureEff $ do @@ -122,26 +120,6 @@ unsafeCoerce1 a = runPureEff $ do Box b <- runReader (Box a) $ raise oops pure b -unsafeCoerce2 :: forall b a. a -> b -unsafeCoerce2 a = runPureEff $ do - backupEs <- unsafeEff cloneEnv - -- 'oops' gains access to the effect stack with Reader (Box b) via the - -- unlifting function that escaped its scope. The problem here is that this - -- effect is no longer in scope. - oops <- runReader @(Box b) (Box undefined) $ do - raiseWith SeqUnlift $ \unlift -> do - pure . unlift $ ask @(Box b) - -- If restoreEnv messes up versioning (i.e. restores the version counter from - -- before the above Reader was used), below code will succeed because the - -- Reader (Box a) will have the same version as Reader (Box b). - unsafeEff $ \es -> restoreEnv es backupEs - -- Put Reader (Box a) where the Reader (Box b) was before and attempt to - -- retrieve 'a' coerced to 'b'. It should fail because 'getLocation' in - -- 'Effectful.Internal.Env' checks that version of the reference is the same - -- as version of the effect. - Box b <- runReader (Box a) $ raise oops - pure b - data Box a = Box a ---------------------------------------- diff --git a/effectful/tests/StateTests.hs b/effectful/tests/StateTests.hs index 336c3bf..87190be 100644 --- a/effectful/tests/StateTests.hs +++ b/effectful/tests/StateTests.hs @@ -51,7 +51,7 @@ test_stateM = runEff $ do U.assertEqual "correct a" "hi" a U.assertEqual "correct b" "hi!!!" b where - getEffectReps = unsafeEff $ \es -> stEffects <$> readIORef' (envStorage es) + getEffectReps = unsafeEff $ \es -> sdEffects . stData <$> readIORef' (envStorage es) test_deepStack :: Assertion test_deepStack = runEff $ do