cleff 0.3.2.0 → 0.3.3.0

raw patch · 14 files changed

+389/−101 lines, 14 filesdep ~basedep ~primitivedep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, primitive, template-haskell, th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +3/−5
• cleff.cabal +16/−4
• src/Cleff/Error.hs +4/−4
• src/Cleff/Internal.hs +18/−10
• src/Cleff/Internal/Base.hs +21/−13
• src/Cleff/Internal/Interpret.hs +31/−18
• src/Cleff/Internal/Monad.hs +28/−21
• src/Cleff/Internal/Rec.hs +6/−16
• src/Cleff/Internal/TH.hs +1/−1
• src/Cleff/Internal/ThreadVar.hs +77/−0
• src/Cleff/Internal/Vec.hs +118/−0
• src/Cleff/State.hs +34/−7
• test/ConcurrencySpec.hs +22/−2

@@ -1,5 +1,15 @@ # Changelog for `cleff` +## 0.3.3.0 (2022-05-21)+ +### Changed++- Slight performance improvements++### Added++- `runStateLocal` that runs the `State` effect with thread-local semantics+ ## 0.3.2.0 (2022-03-13)  ### Changed

@@ -84,12 +84,10 @@  ## Benchmarks -These are the results of the [effect-zoo](https://github.com/ocharles/effect-zoo) microbenchmarks, compiled by GHC 8.10.7. Keep in mind that these are *very short and synthetic programs*, and may or may not tell the accurate performance characteristics of different effect libraries in real use:+These are the results of [`effectful`'s microbenchmarks](https://github.com/haskell-effectful/effectful/tree/master/benchmarks), compiled by GHC 8.10.7. Each diagram shows the average run time of each effect library's implementation of an identical program; lower is better. Each benchmark suite has two flavors - *shallow* and *deep* - where the shallow variant only uses necessary effects, and the deep variant adds 10 redundant `Reader` effects, to simulate more realistic scenarios. Keep in mind that these are *very short and synthetic programs*, and may or may not tell the accurate performance characteristics of different effect libraries in real use. -- `big-stack`: ![big-stack benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-big-stack.png)-- `countdown`: ![countdown benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-countdown.png)-- `file-sizes`: ![file-sizes benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-file-sizes.png)-- `reinterpretation`: ![reinterpretation benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-reinterpretation.png)+- `countdown`: ![countdown benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/benchmark-countdown.png)+- `filesize`: ![filesize benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/benchmark-filesize.png)  ### Differences from `effectful` 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           cleff-version:        0.3.2.0+version:        0.3.3.0 synopsis:       Fast and concise extensible effects description:    Please see the README on GitHub at <https://github.com/re-xyr/cleff#readme> category:       Control, Effect, Language@@ -22,6 +22,7 @@   , GHC == 8.8.4   , GHC == 8.10.7   , GHC == 9.0.2+  , GHC == 9.2.2 extra-source-files:     CHANGELOG.md     README.md@@ -50,6 +51,8 @@       Cleff.Internal.Monad       Cleff.Internal.Rec       Cleff.Internal.TH+      Cleff.Internal.ThreadVar+      Cleff.Internal.Vec       Cleff.Mask       Cleff.Output       Cleff.Reader@@ -74,9 +77,10 @@       FunctionalDependencies       GADTs       GeneralizedNewtypeDeriving-      KindSignatures       LambdaCase+      MagicHash       NoStarIsType+      PatternSynonyms       PolyKinds       RankNTypes       RoleAnnotations@@ -89,6 +93,8 @@       TypeOperators       UndecidableInstances       UnicodeSyntax+      UnliftedFFITypes+      ViewPatterns   ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -Wmissing-export-lists   build-depends:       atomic-primops ==0.8.*@@ -132,9 +138,10 @@       FunctionalDependencies       GADTs       GeneralizedNewtypeDeriving-      KindSignatures       LambdaCase+      MagicHash       NoStarIsType+      PatternSynonyms       PolyKinds       RankNTypes       RoleAnnotations@@ -147,6 +154,8 @@       TypeOperators       UndecidableInstances       UnicodeSyntax+      UnliftedFFITypes+      ViewPatterns   ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N   build-depends:       atomic-primops ==0.8.*@@ -196,9 +205,10 @@       FunctionalDependencies       GADTs       GeneralizedNewtypeDeriving-      KindSignatures       LambdaCase+      MagicHash       NoStarIsType+      PatternSynonyms       PolyKinds       RankNTypes       RoleAnnotations@@ -211,6 +221,8 @@       TypeOperators       UndecidableInstances       UnicodeSyntax+      UnliftedFFITypes+      ViewPatterns   ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N   build-depends:       atomic-primops ==0.8.*

@@ -123,7 +123,7 @@ type ExcUid = Int  -- | Exception wrapper used in 'runError' in order not to conflate error types with exception types.-data ErrorExc = ErrorExc {-# UNPACK #-} !ExcUid Any+data ErrorExc = ErrorExc !ExcUid Any   deriving anyclass (Exception)  instance Show ErrorExc where@@ -134,8 +134,8 @@     \those shenanigans mentioned or other similar ones seem unlikely, please report this as a bug." <>)  catch' :: ∀ e m a. MonadUnliftIO m => ExcUid -> m a -> (e -> m a) -> m a-catch' eid m h = m `Exc.catch` \ex@(ErrorExc eid' e) ->-  if eid == eid' then h (fromAny e) else Exc.throwIO ex+catch' eid m h = m `Exc.catch` \ex@(ErrorExc eid' (Any e)) ->+  if eid == eid' then h e else Exc.throwIO ex {-# INLINE catch' #-}  try' :: ∀ e m a. MonadUnliftIO m => ExcUid -> m a -> m (Either e a)@@ -152,7 +152,7 @@  errorHandler :: ExcUid -> Handler (Error e) (IOE : es) errorHandler eid = \case-  ThrowError e     -> Exc.throwIO $ ErrorExc eid (toAny e)+  ThrowError e     -> Exc.throwIO $ ErrorExc eid (Any e)   CatchError m' h' -> withToIO \toIO -> liftIO $ catch' eid (toIO m') (toIO . h') {-# INLINE errorHandler #-} 

@@ -14,10 +14,13 @@     Effect   , type (~>)   , type (++)+  , HandlerPtr (HandlerPtr, unHandlerPtr)     -- * The 'Any' type   , Any+  , pattern Any   , fromAny-  , toAny+    -- * Miscellaneous+  , noinline   ) where  import           Data.Kind     (Type)@@ -47,13 +50,18 @@   (x : xs) ++ ys = x : (xs ++ ys) infixr 5 ++ --- | Coerce any boxed value into 'Any'.-toAny :: a -> Any-toAny = unsafeCoerce-{-# INLINE toAny #-}+-- | A pointer to an effect handler.+type role HandlerPtr nominal+newtype HandlerPtr (e :: Effect) = HandlerPtr { unHandlerPtr :: Int } --- | Coerce 'Any' to a boxed value. This is /generally unsafe/ and it is your responsibility to ensure that the type--- you're coercing into is the original type that the 'Any' is coerced from.-fromAny :: Any -> a-fromAny = unsafeCoerce-{-# INLINE fromAny #-}+-- | A pattern synonym for coercing values to and from 'Any'. This is not any less unsafe but prevents possivle+-- misuses.+pattern Any :: forall a. a -> Any+pattern Any {fromAny} <- (unsafeCoerce -> fromAny)+  where Any = unsafeCoerce+{-# COMPLETE Any #-}++-- | Magic function that tells the compiler /not/ to inline the argument.+noinline :: a -> a+noinline x = x+{-# NOINLINE noinline #-}

@@ -24,6 +24,7 @@   , thisIsPureTrustMe   , runIOE   , runPure+  , runPureIO     -- * Effect interpretation   , HandlerIO   , interpretIO@@ -35,6 +36,7 @@ import           Cleff.Internal import           Cleff.Internal.Interpret import           Cleff.Internal.Monad+import qualified Cleff.Internal.Rec          as Rec import           Control.Monad.Base          (MonadBase (liftBase)) import           Control.Monad.Catch         (ExitCase (ExitCaseException, ExitCaseSuccess), MonadCatch, MonadMask,                                               MonadThrow)@@ -81,21 +83,18 @@ -- instead, or if you're interpreting higher-order effects, use 'fromIO'. primLiftIO :: IO a -> Eff es a primLiftIO = Eff . const-{-# INLINE primLiftIO #-}  -- | Give a runner function a way to run 'Eff' actions as an 'IO' computation. This function is /highly unsafe/ and -- should not be used directly; use 'withRunInIO' instead, or if you're interpreting higher-order effects, use -- 'withToIO'. primUnliftIO :: ((Eff es ~> IO) -> IO a) -> Eff es a-primUnliftIO f = Eff \es -> f (`unEff` es)-{-# INLINE primUnliftIO #-}+primUnliftIO f = Eff \es -> f \(Eff m) -> m es  instance IOE :> es => MonadIO (Eff es) where #ifdef DYNAMIC_IOE   liftIO = send . Lift #else   liftIO = primLiftIO-  {-# INLINE liftIO #-} #endif  instance IOE :> es => MonadUnliftIO (Eff es) where@@ -103,7 +102,6 @@   withRunInIO f = send $ Unlift f #else   withRunInIO = primUnliftIO-  {-# INLINE withRunInIO #-} #endif  instance IOE :> es => MonadThrow (Eff es) where@@ -143,24 +141,32 @@ -- uses 'IO' but does not do anything really /impure/ (/i.e./ can be safely used 'unsafeDupablePerformIO' on), such as a -- State effect. thisIsPureTrustMe :: Eff (IOE : es) ~> Eff es-thisIsPureTrustMe = interpret \case-#ifdef DYNAMIC_IOE-  Lift m   -> primLiftIO m-  Unlift f -> primUnliftIO \runInIO -> f (runInIO . toEff)+thisIsPureTrustMe =+#ifndef DYNAMIC_IOE+  adjust (Rec.cons $ HandlerPtr (-1))+#else+  interpret \case+    Lift m   -> primLiftIO m+    Unlift f -> primUnliftIO \runInIO -> f (runInIO . toEff) #endif {-# INLINE thisIsPureTrustMe #-}  -- | Unwrap an 'Eff' computation with side effects into an 'IO' computation, given that all effects other than 'IOE' are -- interpreted. runIOE :: Eff '[IOE] ~> IO-runIOE m = unEff (thisIsPureTrustMe m) emptyEnv+runIOE = runPureIO . thisIsPureTrustMe {-# INLINE runIOE #-}  -- | Unwrap a pure 'Eff' computation into a pure value, given that all effects are interpreted. runPure :: Eff '[] a -> a-runPure m = unsafeDupablePerformIO $ unEff m emptyEnv-{-# NOINLINE runPure #-}+runPure = unsafeDupablePerformIO . runPureIO+{-# INLINE runPure #-} +-- | Unwrap a pure 'Eff' computation into an 'IO' computation. You may occasionally need this.+runPureIO :: Eff '[] ~> IO+runPureIO = \(Eff m) -> m emptyEnv+{-# INLINE runPureIO #-}+ -- * Effect interpretation  -- | The type of an /'IO' effect handler/, which is a function that transforms an effect @e@ into 'IO' computations.@@ -197,7 +203,8 @@ --     'Control.Exception.bracket' (toIO alloc) (toIO . dealloc) (toIO . use) -- @ withToIO :: (Handling esSend e es, IOE :> es) => ((Eff esSend ~> IO) -> IO a) -> Eff es a-withToIO f = Eff \es -> f \m -> unEff m (updateEnv es esSend)+withToIO f = Eff \es -> f \(Eff m) -> m (updateEnv es esSend)+{-# INLINE withToIO #-}  -- | Lift an 'IO' computation into @'Eff' esSend@. This is analogous to 'liftIO', and is only useful in dealing with -- effect operations with the monad type in the negative position, for example 'Control.Exception.mask'ing:@@ -222,3 +229,4 @@ -- and the returned 'IO' computation is recovered into 'Eff' with 'fromIO'. fromIO :: (Handling esSend e es, IOE :> es) => IO ~> Eff esSend fromIO = Eff . const+{-# INLINE fromIO #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UnboxedTuples       #-} {-# OPTIONS_HADDOCK not-home #-} -- | -- Copyright: (c) 2021 Xy Ren@@ -14,8 +13,10 @@ -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be -- extra careful if you're to depend on this module. module Cleff.Internal.Interpret-  ( -- * Trivial handling-    adjust+  ( -- * General transformation+    alter+  , adjust+    -- * Trivial handling   , raise   , raiseN   , inject@@ -56,11 +57,15 @@  -- * Trivial handling --- | Adjust the effect stack by a contravariant transformation function over the stack. This function reveals the+-- | Alter the effect environment by a contravariant transformation function over it. This function reveals the -- profunctorial nature of 'Eff'; in particular, 'Eff' is a profunctor @['Effect'] -> 'Data.Kind.Type'@, @lmap@ is--- 'adjust', and @rmap@ is 'fmap'.+-- 'alter', and @rmap@ is 'fmap'.+alter :: ∀ es es'. (Env es' -> Env es) -> Eff es ~> Eff es'+alter f = \(Eff m) -> Eff \es -> m (f es)++-- | A specialized version of 'alter' that only adjusts the effect stack. adjust :: ∀ es es'. (Rec es' -> Rec es) -> Eff es ~> Eff es'-adjust f m = Eff (unEff m . adjustEnv f)+adjust f = alter (adjustEnv f)  -- | Lift a computation into a bigger effect stack with one more effect. For a more general version see 'raiseN'. raise :: ∀ e es. Eff es ~> Eff (e : es)@@ -155,12 +160,10 @@ -- | Get the pointer to the current effect handler itself. hdlPtr :: ∀ esSend e es. Handling esSend e es => HandlerPtr e hdlPtr = let SendSite _ ptr = sendSite @esSend in ptr-{-# INLINE hdlPtr #-}  -- | Get the send-site 'Env'. esSend :: Handling esSend e es => Env esSend esSend = let SendSite env _ = sendSite in env-{-# INLINE esSend #-}  -- | Newtype wrapper for instantiating the 'Handling' typeclass locally, a la the reflection trick. We do not use -- the @reflection@ library directly so as not to expose this piece of implementation detail to the user.@@ -170,7 +173,6 @@ -- be directly used anyhow. instHandling :: ∀ esSend e es a. (Handling esSend e es => a) -> SendSite esSend e -> a instHandling x = unsafeCoerce (InstHandling x :: InstHandling esSend e es a)-{-# INLINE instHandling #-}  -- | The type of an /effect handler/, which is a function that transforms an effect @e@ from an arbitrary effect stack -- into computations in the effect stack @es@.@@ -190,24 +192,28 @@ -- | Interpret an effect @e@ in terms of effects in the effect stack @es@ with an effect handler. interpret :: ∀ e es. Handler e es -> Eff (e : es) ~> Eff es interpret = reinterpretN @'[]+{-# INLINE interpret #-}  -- | Like 'interpret', but adds a new effect @e'@ to the stack that can be used in the handler. reinterpret :: ∀ e' e es. Handler e (e' : es) -> Eff (e : es) ~> Eff (e' : es) reinterpret = reinterpretN @'[e']+{-# INLINE reinterpret #-}  -- | Like 'reinterpret', but adds two new effects. reinterpret2 :: ∀ e' e'' e es. Handler e (e' : e'' : es) -> Eff (e : es) ~> Eff (e' : e'' : es) reinterpret2 = reinterpretN @'[e', e'']+{-# INLINE reinterpret2 #-}  -- | Like 'reinterpret', but adds three new effects. reinterpret3 :: ∀ e' e'' e''' e es. Handler e (e' : e'' : e''' : es) -> Eff (e : es) ~> Eff (e' : e'' : e''' : es) reinterpret3 = reinterpretN @'[e', e'', e''']+{-# INLINE reinterpret3 #-}  -- | Like 'reinterpret', but adds arbitrarily many new effects. This function requires @TypeApplications@. reinterpretN :: ∀ es' e es. KnownList es' => Handler e (es' ++ es) -> Eff (e : es) ~> Eff (es' ++ es)-reinterpretN handle m = Eff \es ->-  let (# ptr, es' #) = allocaEnv es-  in unEff m $ appendEnv ptr (mkInternalHandler ptr es' handle) $ adjustEnv (Rec.drop @es') es'+reinterpretN handle = alter \es -> appendEnv+  (mkInternalHandler (peekEnv es) es handle)+  (adjustEnv (Rec.drop @es') es) {-# INLINE reinterpretN #-}  -- | Respond to an effect, but does not eliminate it from the stack. This means you can re-send the operations in the@@ -215,16 +221,18 @@ -- logging. interpose :: ∀ e es. e :> es => Handler e es -> Eff es ~> Eff es interpose = imposeN @'[]+{-# INLINE interpose #-}  -- | Like 'interpose', but allows to introduce one new effect to use in the handler. impose :: ∀ e' e es. e :> es => Handler e (e' : es) -> Eff es ~> Eff (e' : es) impose = imposeN @'[e']+{-# INLINE impose #-}  -- | Like 'impose', but allows introducing arbitrarily many effects. This requires @TypeApplications@. imposeN :: ∀ es' e es. (KnownList es', e :> es) => Handler e (es' ++ es) -> Eff es ~> Eff (es' ++ es)-imposeN handle m = Eff \es ->-  let (# ptr, es' #) = allocaEnv es-  in unEff m $ replaceEnv ptr (mkInternalHandler ptr es' handle) $ adjustEnv (Rec.drop @es') es'+imposeN handle = alter \es -> replaceEnv+  (mkInternalHandler (peekEnv es) es handle)+  (adjustEnv (Rec.drop @es') es) {-# INLINE imposeN #-}  -- * Translating effects@@ -236,6 +244,7 @@ -- @ transform :: ∀ e e' es. e' :> es => Translator e e' -> Eff (e : es) ~> Eff es transform trans = interpret (sendVia toEff . trans)+{-# INLINE transform #-}  -- | Like 'transform', but instead of using an effect in stack, add a new one to the top of it. --@@ -244,6 +253,7 @@ -- @ translate :: ∀ e e' es. Translator e e' -> Eff (e : es) ~> Eff (e' : es) translate trans = reinterpret (sendVia toEff . trans)+{-# INLINE translate #-}  -- * Combinators for interpreting higher effects @@ -278,7 +288,8 @@ --     ('toEff' . use) -- @ toEff :: Handling esSend e es => Eff esSend ~> Eff es-toEff m = Eff \es -> unEff m (updateEnv es esSend)+toEff = alter \es -> updateEnv es esSend+{-# INLINE toEff #-}  -- | Run a computation in the current effect stack, just like 'toEff', but takes a 'Handler' of the current effect -- being interpreted, so that inside the computation being ran, the effect is interpreted differently. This is useful@@ -294,13 +305,15 @@ --       'Cleff.Reader.Local' f m -> 'toEffWith' (handle $ f r) m -- @ toEffWith :: ∀ esSend e es. Handling esSend e es => Handler e es -> Eff esSend ~> Eff es-toEffWith handle m = Eff \es -> unEff m $+toEffWith handle = alter \es ->   -- The 'Handling' constraint of 'handle' will NOT be prematurely initialized here because that will make 'handle'   -- monomorphic. Therefore this usage is safe.   writeEnv (hdlPtr @esSend) (mkInternalHandler (hdlPtr @esSend) es handle) $ updateEnv es esSend+{-# INLINE toEffWith #-}  -- | Temporarily gain the ability to lift some @'Eff' es@ actions into @'Eff' esSend@. This is only useful for dealing -- with effect operations with the monad type in the negative position, which means it's unlikely that you need to use -- this function in implementing your effects. withFromEff :: Handling esSend e es => ((Eff es ~> Eff esSend) -> Eff esSend a) -> Eff es a-withFromEff f = Eff \es -> unEff (f \m -> Eff \ess -> unEff m (updateEnv ess es)) (updateEnv es esSend)+withFromEff f = Eff \es -> unEff (f $ alter \ess -> updateEnv ess es) (updateEnv es esSend)+{-# INLINE withFromEff #-}

@@ -1,4 +1,3 @@-{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- | -- Copyright: (c) 2021 Xy Ren@@ -21,7 +20,7 @@   , HandlerPtr   , emptyEnv   , adjustEnv-  , allocaEnv+  , peekEnv   , readEnv   , writeEnv   , replaceEnv@@ -38,12 +37,12 @@   ) where  import           Cleff.Internal-import           Cleff.Internal.Rec  (HandlerPtr (HandlerPtr, unHandlerPtr), KnownList, Rec, Subset, type (:>))+import           Cleff.Internal.Rec  (KnownList, Rec, Subset, type (:>)) import qualified Cleff.Internal.Rec  as Rec+import           Cleff.Internal.Vec  (Vec)+import qualified Cleff.Internal.Vec  as Vec import           Control.Applicative (Applicative (liftA2)) import           Control.Monad.Fix   (MonadFix (mfix))-import           Data.IntMap.Strict  (IntMap)-import qualified Data.IntMap.Strict  as Map import           Data.Kind           (Constraint)  -- * The 'Eff' monad@@ -59,16 +58,22 @@ -- which is a type-level list that holds all effects available. -- -- The best practice is to always use a polymorphic type variable for the effect stack @es@, and then use the type--- operators '(:>)' and '(:>>)' in constraints to indicate what effects are available in the stack. For example,+-- operator '(:>)' in constraints to indicate what effects are available in the stack. For example, -- -- @ -- ('Cleff.Reader.Reader' 'String' ':>' es, 'Cleff.State.State' 'Bool' ':>' es) => 'Eff' es 'Integer' -- @ -- -- means you can perform operations of the @'Cleff.Reader.Reader' 'String'@ effect and the @'Cleff.State.State' 'Bool'@--- effect in a computation returning an 'Integer'. The reason why you should always use a polymorphic effect stack as--- opposed to a concrete list of effects are that+-- effect in a computation returning an 'Integer'. A convenient shorthand, '(:>>)', can also be used to indicate+-- multiple effects being in a stack: --+-- @+-- '['Cleff.Reader.Reader' 'String', 'Cleff.State.State' 'Bool'] ':>>' es => 'Eff' es 'Integer'+-- @+--+-- The reason why you should always use a polymorphic effect stack as opposed to a concrete list of effects are that:+-- -- * it can contain other effects that are used by computations other than the current one, and -- * it does not require you to run the effects in any particular order. type role Eff nominal representational@@ -116,41 +121,41 @@ data Env (es :: [Effect]) = Env   {-# UNPACK #-} !Int -- ^ The next address to allocate.   {-# UNPACK #-} !(Rec es) -- ^ The effect stack storing pointers to handlers.-  !(IntMap Any) -- ^ The map that corresponds pointers to handlers.+  !(Vec Any) -- ^ The storage that corresponds pointers to handlers.  -- | Create an empty 'Env' with no address allocated. emptyEnv :: Env '[]-emptyEnv = Env 0 Rec.empty Map.empty+emptyEnv = Env 0 Rec.empty Vec.empty {-# INLINE emptyEnv #-}  -- | Adjust the effect stack via an function over 'Rec'. adjustEnv :: ∀ es' es. (Rec es -> Rec es') -> Env es -> Env es'-adjustEnv f (Env n re mem) = Env n (f re) mem+adjustEnv f = \(Env n re mem) -> Env n (f re) mem {-# INLINE adjustEnv #-} --- | Allocate a new, empty address for a handler. \( O(1) \).-allocaEnv :: ∀ e es. Env es -> (# HandlerPtr e, Env es #)-allocaEnv (Env n re mem) = (# HandlerPtr n, Env (n + 1) re mem #)-{-# INLINE allocaEnv #-}+-- | Peek the next address to be allocated. \( O(1) \).+peekEnv :: ∀ e es. Env es -> HandlerPtr e+peekEnv (Env n _ _) = HandlerPtr n+{-# INLINE peekEnv #-}  -- | Read the handler a pointer points to. \( O(1) \). readEnv :: ∀ e es. e :> es => Env es -> InternalHandler e-readEnv (Env _ re mem) = fromAny $ mem Map.! unHandlerPtr (Rec.index @e re)+readEnv (Env _ re mem) = fromAny $ Vec.lookup (unHandlerPtr (Rec.index @e re)) mem {-# INLINE readEnv #-}  -- | Overwrite the handler a pointer points to. \( O(1) \). writeEnv :: ∀ e es. HandlerPtr e -> InternalHandler e -> Env es -> Env es-writeEnv (HandlerPtr m) x (Env n re mem) = Env n re (Map.insert m (toAny x) mem)+writeEnv (HandlerPtr m) x (Env n re mem) = Env n re (Vec.update m (Any x) mem) {-# INLINE writeEnv #-}  -- | Replace the handler pointer of an effect in the stack. \( O(n) \).-replaceEnv :: ∀ e es. e :> es => HandlerPtr e -> InternalHandler e -> Env es -> Env es-replaceEnv (HandlerPtr m) x (Env n re mem) = Env n (Rec.update @e (HandlerPtr m) re) (Map.insert m (toAny x) mem)+replaceEnv :: ∀ e es. e :> es => InternalHandler e -> Env es -> Env es+replaceEnv x (Env n re mem) = Env (n + 1) (Rec.update @e (HandlerPtr n) re) (Vec.snoc mem (Any x)) {-# INLINE replaceEnv #-}  -- | Add a new effect to the stack with its corresponding handler pointer. \( O(n) \).-appendEnv :: ∀ e es. HandlerPtr e -> InternalHandler e -> Env es -> Env (e : es)-appendEnv (HandlerPtr m) x (Env n re mem) = Env n (Rec.cons (HandlerPtr m) re) (Map.insert m (toAny x) mem)+appendEnv :: ∀ e es. InternalHandler e -> Env es -> Env (e : es)+appendEnv x (Env n re mem) = Env (n + 1) (Rec.cons (HandlerPtr n) re) (Vec.snoc mem (Any x)) {-# INLINE appendEnv #-}  -- | Use the state of LHS as a newer version for RHS. \( O(1) \).@@ -171,6 +176,7 @@ -- effect stack. send :: e :> es => e (Eff es) ~> Eff es send = sendVia id+{-# INLINE send #-}  -- | Perform an action in another effect stack via a transformation to that stack; in other words, this function "maps" -- the effect operation from effect stack @es@ to @es'@. This is a largely generalized version of 'send'; only use this@@ -183,3 +189,4 @@ -- @since 0.2.0.0 sendVia :: e :> es' => (Eff es ~> Eff es') -> e (Eff es) ~> Eff es' sendVia f e = Eff \es -> unEff (f (runHandler (readEnv es) e)) es+{-# INLINE sendVia #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE MagicHash           #-} {-# LANGUAGE UnboxedTuples       #-} {-# OPTIONS_HADDOCK not-home #-} -- |@@ -20,8 +19,7 @@ -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be -- extra careful if you're to depend on this module. module Cleff.Internal.Rec-  ( HandlerPtr (HandlerPtr, unHandlerPtr)-  , Rec+  ( Rec   , type (++)     -- * Construction   , empty@@ -42,6 +40,7 @@   ) where  import           Cleff.Internal+import           Data.Foldable            (for_) import           Data.Primitive.PrimArray (MutablePrimArray (MutablePrimArray), PrimArray (PrimArray), copyPrimArray,                                            indexPrimArray, newPrimArray, writePrimArray) import           GHC.Exts                 (runRW#, unsafeFreezeByteArray#)@@ -49,10 +48,6 @@ import           GHC.TypeLits             (ErrorMessage (ShowType, Text, (:<>:)), TypeError) import           Prelude                  hiding (concat, drop, head, tail, take) --- | A pointer to an effect handler.-type role HandlerPtr nominal-newtype HandlerPtr (e :: Effect) = HandlerPtr { unHandlerPtr :: Int }- -- | Extensible record type supporting efficient \( O(1) \) reads. The underlying implementation is 'PrimArray' -- slices. type role Rec nominal@@ -133,7 +128,7 @@ class (e :: Effect) :> (es :: [Effect]) where   -- | Get the index of the element.   reifyIndex :: Int-  reifyIndex = unreifiable "Elem" "Cleff.Internal.Rec.reifyIndex" "the index of an element of a type-level list"+  reifyIndex = unreifiable "Elem" "Cleff.Internal.Rec.reifyIndex" "the index of an effect in the effect stack" infix 0 :>  -- | The element closer to the head takes priority.@@ -158,7 +153,7 @@   -- | Get a list of indices of the elements.   reifyIndices :: [Int]   reifyIndices = unreifiable-    "Subset" "Cleff.Internal.Rec.reifyIndices" "the index of multiple elements of a type-level list"+    "Subset" "Cleff.Internal.Rec.reifyIndices" "the indices of a subset of the effect stack"  instance Subset '[] es where   reifyIndices = []@@ -170,14 +165,9 @@ pick :: ∀ es es'. Subset es es' => Rec es' -> Rec es pick (Rec off _ arr) = Rec 0 (reifyLen @es) $ runPrimArray do   marr <- newPrimArray (reifyLen @es)-  go marr 0 (reifyIndices @es @es')+  for_ (zip [0..] (reifyIndices @es @es')) \(newIx, ix) ->+    writePrimArray marr newIx $ indexPrimArray arr (off + ix)   pure marr-  where-    go :: MutablePrimArray s Int -> Int -> [Int] -> ST s ()-    go _ _ [] = pure ()-    go marr newIx (ix : ixs) = do-      writePrimArray marr newIx $ indexPrimArray arr (off + ix)-      go marr (newIx + 1) ixs  -- | Update an entry in the record. \( O(n) \). update :: ∀ e es. e :> es => HandlerPtr e -> Rec es -> Rec es

@@ -109,7 +109,7 @@   pure $     maybeToList ((`InfixD` name) <$> fixity) ++     [ SigD fnName fnSig | shouldMakeSig ] ++-    [ FunD fnName [Clause (VarP <$> fnArgs) (NormalB fnBody) []] ]+    [ FunD fnName [Clause [] (NormalB $ LamE (VarP <$> fnArgs) fnBody) []] ]    where     -- Uncapitalize the first letter / remove the ':' in operator constructors

@@ -0,0 +1,77 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Copyright: (c) 2021 Xy Ren+-- License: BSD3+-- Maintainer: xy.r@outlook.com+-- Stability: unstable+-- Portability: non-portable (GHC only)+--+-- This module contains a contention-free thread-local variable datatype.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.ThreadVar (ThreadVar, newThreadVar, getThreadVar) where++import           Cleff.Internal+import           Control.Monad.IO.Class (MonadIO (liftIO))+import           Data.Atomics           (atomicModifyIORefCAS_)+import           Data.IntMap.Strict     (IntMap)+import qualified Data.IntMap.Strict     as Map+import           Foreign.C.Types+import           GHC.Conc               (ThreadId (ThreadId))+import           GHC.Exts               (ThreadId#, mkWeak#)+import           GHC.IO                 (IO (IO))+import           UnliftIO.Concurrent    (myThreadId)+import           UnliftIO.IORef         (IORef, newIORef, readIORef)++-- | Get the hash for a 'ThreadId' in terms of C types (RTS function).+#if __GLASGOW_HASKELL__ >= 903+foreign import ccall unsafe "rts_getThreadId"+  getThreadId :: ThreadId# -> CULLong+#elif __GLASGOW_HASKELL__ >= 900+foreign import ccall unsafe "rts_getThreadId"+  getThreadId :: ThreadId# -> CLong+#else+foreign import ccall unsafe "rts_getThreadId"+  getThreadId :: ThreadId# -> CInt+#endif++-- | Generates a numeric hash for a 'ThreadId'. Before GHC 9.4, this function has a practical possibility of hash+-- collision on 32-bit or Windows platforms, if threads are created rapidly and thread count exceeds 2^32. After GHC+-- 9.4, this function practically won't produce collision as the hash is extended to 64-bit on all platforms.+hashThreadId :: ThreadId -> Int+hashThreadId (ThreadId tid#) = fromIntegral (getThreadId tid#)++-- | Attach a finalizer (an 'IO' computation) to a thread.+attachFinalizer :: ThreadId -> IO () -> IO ()+attachFinalizer (ThreadId tid#) (IO finalize#) = IO \s1 -> let+  !(# s2, _ #) = mkWeak# tid# () finalize# s1+  in (# s2, () #)++-- | A thread-local variable. It is designed so that any operation originating from existing threads produce no+-- contention; thread contention only occurs when multiple new threads attempt to first-time access the variable+-- at the same time.+data ThreadVar a = ThreadVar a {-# UNPACK #-} !(IORef (IntMap (IORef a)))++-- | Create a thread variable with a same initial value for each thread.+newThreadVar :: MonadIO m => a -> m (ThreadVar a)+newThreadVar x = ThreadVar x <$> newIORef Map.empty++-- | Get the variable local to this thread, in the form of an 'IORef'. It is guaranteed that the returned 'IORef'+-- will not be read or mutated by other threads inadvertently.+getThreadVar :: MonadIO m => ThreadVar a -> m (IORef a)+getThreadVar (ThreadVar x0 table) = do+  tid <- myThreadId+  let thash = hashThreadId tid+  maybeRef <- Map.lookup thash <$> readIORef table+  case maybeRef of+    Nothing -> do+      ref <- newIORef x0+      liftIO $ noinline atomicModifyIORefCAS_ table (Map.insert thash ref)+      liftIO $ attachFinalizer tid $+        noinline atomicModifyIORefCAS_ table (Map.delete thash)+      pure ref+    Just ref -> pure ref+{-# INLINE getThreadVar #-}

@@ -0,0 +1,118 @@+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Copyright: (c) 2021 Xy Ren+-- License: BSD3+-- Maintainer: xy.r@outlook.com+-- Stability: unstable+-- Portability: non-portable (GHC only)+--+-- This module contains an efficient vector datatype that is implemented as a radix tree.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.Vec (Vec, empty, lookup, update, snoc) where++import           Control.Monad.ST          (ST)+import           Data.Bits                 (Bits (unsafeShiftL, unsafeShiftR, (.&.)), FiniteBits (countTrailingZeros))+import           Data.Primitive.MachDeps   (sIZEOF_INT)+import           Data.Primitive.SmallArray (SmallArray, SmallMutableArray, copySmallArray, indexSmallArray,+                                            newSmallArray, readSmallArray, runSmallArray, sizeofSmallArray,+                                            thawSmallArray, writeSmallArray)+import           Prelude                   hiding (lookup)++-- | An efficient vector type, implemented as a radix tree. It has the following time complexities:+--+-- * Lookup: \( O(\log n) \)+-- * Update: \( O(\log n) \)+-- * Append: \( O(\log n) \)+--+-- The branching factor (base of log) is 32 therefore the time is close to constant in most cases. Note that in+-- practice, lookup is faster than update, and update is faster than append.+data Vec a = Vec !Int !(Tree a)++type Shift = Int++-- | The \( \log_2 \) of the branching factor. The branching factor is set to be 32 for now but may change in the+-- future.+factor :: Int+factor = 5++-- | A mask covering one chunk of an index.+initialMask :: Int+initialMask = (1 `unsafeShiftL` factor) - 1++-- | A radix tree. The tree is always left-leaning.+data Tree a+  = Tip+    {-# UNPACK #-} !(SmallArray a)+  | Node+    {-# UNPACK #-} !Shift+    {-# UNPACK #-} !(SmallArray (Tree a))++-- | Mask a portion of an index.+mask :: Shift -> Int -> Int+mask s x = initialMask .&. (x `unsafeShiftR` s)++-- | Mask the zeroth portion of the index.+mask0 :: Int -> Int+mask0 x = initialMask .&. x++-- | Alter an element in a 'SmallMutableArray' by a function.+alterSmallArray :: SmallMutableArray s a -> Int -> (a -> a) -> ST s ()+alterSmallArray marr ix f = do+  x <- readSmallArray marr ix+  writeSmallArray marr ix $! f x++-- | The empty 'Vec'.+empty :: Vec a+empty = Vec 0 $ Tip $ runSmallArray $ newSmallArray 0 $ error+  "Cleff.Internal.Vec: Encountered an element in an empty Vec. Please report this as a bug."++-- | Lookup in a 'Vec' by an index. This does not perform any bounds check.+lookup :: Int -> Vec a -> a+lookup ix (Vec _ tree) = go tree+  where+    go (Tip arr)    = indexSmallArray arr (initialMask .&. ix)+    go (Node s arr) = go (indexSmallArray arr (mask s ix))++-- | Update a value in a 'Vec' by an index. The value will be forced before installing. This does not perform any+-- bounds check.+update :: Int -> a -> Vec a -> Vec a+update ix x (Vec len tree) = Vec len (go tree)+  where+    go (Tip arr) = Tip $ runSmallArray do+      marr <- thawSmallArray arr 0 (sizeofSmallArray arr)+      writeSmallArray marr (mask0 ix) $! x+      pure marr+    go (Node s arr) = Node s $ runSmallArray do+      marr <- thawSmallArray arr 0 (sizeofSmallArray arr)+      alterSmallArray marr (mask s ix) go+      pure marr++-- | Append a value to a 'Vec'. The value will be forced before installing. This does not perform any bounds check.+snoc :: Vec a -> a -> Vec a+snoc (Vec len tree) x+  | ins <= topShift = Vec (len + 1) (go tree)+  | otherwise = Vec (len + 1) $ Node (topShift + factor) $ runSmallArray $ do+    marr <- newSmallArray 2 $! tree+    writeSmallArray marr 1 $! branch topShift+    pure marr+  where+    topShift = case tree of+      Tip _    -> 0+      Node s _ -> s+    ins = (countTrailingZeros len `mod` sIZEOF_INT `div` factor) * factor+    branch 0 = Tip $ runSmallArray $ newSmallArray 1 $! x+    branch s = Node s $ runSmallArray $ newSmallArray 1 $! branch (s - factor)+    enlarge arr new = runSmallArray do+      let sz = sizeofSmallArray arr+      marr <- newSmallArray (sz + 1) $! new+      copySmallArray marr 0 arr 0 sz+      pure marr+    go (Tip arr) = Tip $ enlarge arr x+    go (Node s arr)+      | ins == s = Node s $ enlarge arr $ branch (s - factor)+      | otherwise = Node s $ runSmallArray do+        marr <- thawSmallArray arr 0 (sizeofSmallArray arr)+        alterSmallArray marr (mask s len) go+        pure marr

@@ -16,6 +16,7 @@   , modify     -- * Interpretations   , runState+  , runStateLocal   , runStateIORef   , runStateMVar   , runStateTVar@@ -24,13 +25,14 @@  import           Cleff import           Cleff.Internal.Base-import           Control.Monad       (void)-import           Data.Atomics        (atomicModifyIORefCAS)-import           Data.Tuple          (swap)-import           Lens.Micro          (Lens', (&), (.~), (^.))-import           UnliftIO.IORef      (IORef, newIORef, readIORef, writeIORef)-import           UnliftIO.MVar       (MVar, modifyMVar, readMVar, swapMVar)-import           UnliftIO.STM        (TVar, atomically, readTVar, readTVarIO, writeTVar)+import           Cleff.Internal.ThreadVar+import           Control.Monad            (void)+import           Data.Atomics             (atomicModifyIORefCAS)+import           Data.Tuple               (swap)+import           Lens.Micro               (Lens', (&), (.~), (^.))+import           UnliftIO.IORef           (IORef, newIORef, readIORef, writeIORef)+import           UnliftIO.MVar            (MVar, modifyMVar, readMVar, swapMVar)+import           UnliftIO.STM             (TVar, atomically, readTVar, readTVarIO, writeTVar)  -- * Effect @@ -93,6 +95,31 @@   s' <- readIORef rs   pure (x, s') {-# INLINE runState #-}++-- | Run a 'State' effect where each thread has its thread-local state.+--+-- This means that each thread will have an individual state that has the same initial value. Threfore, state+-- operations on one thread will not change the state for any other thread.+--+-- The returned final state is that of the current thread.+--+-- === Caveats+--+-- Like 'runState', the 'state' operation in this handler is atomic. Like 'runState', and unlike 'mtl', any errors will+-- not revert the state changes.+--+-- Be warned that if you use a thread pool, then when a thread is reused, it may read the state left from the last+-- usage, therefore losing locality. If you use a thread pool, you will want to manually reset the state after each+-- task.+--+-- @since 0.3.3.0+runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateLocal s m = thisIsPureTrustMe do+  rs <- newThreadVar s+  x <- reinterpret (\e -> getThreadVar rs >>= \r -> handleIORef r e) m+  s' <- readIORef =<< getThreadVar rs+  pure (x, s')+{-# INLINE runStateLocal #-}  -- | Run the 'State' effect in terms of operations on a supplied 'IORef'. The 'state' operation is atomic. --

@@ -3,16 +3,17 @@ import           Cleff import           Cleff.Error         (runError, throwError) import           Cleff.State-import           Control.Monad       (when)+import           Control.Monad       (void, when) import           Data.Set            (Set) import qualified Data.Set            as Set import           Test.Hspec-import           UnliftIO            (concurrently_)+import           UnliftIO            (concurrently_, replicateConcurrently_) import           UnliftIO.Concurrent (threadDelay)  spec :: Spec spec = do   sharedState+  localState   errorHandling  sharedState :: Spec@@ -29,6 +30,25 @@         when (f n) $ do           modify $ Set.insert n         addWhen f $ n - 1++localState :: Spec+localState = it "should have local state" $+  void $ runIOE $ runStateLocal x $ do+    replicateConcurrently_ 2 $ do+      r <- goDownward 0+      liftIO $ r `shouldBe` x+  where+    x :: Int+    x = 100000++    goDownward :: State Int :> es => Int -> Eff es Int+    goDownward acc = do+      end <- state @Int $ \case+        0 -> (True,  0)+        n -> (False, n - 1)+      if end+        then pure acc+        else goDownward $ acc + 1  errorHandling :: Spec errorHandling = it "should handle errors properly" do