diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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` diff --git a/cleff.cabal b/cleff.cabal --- a/cleff.cabal +++ b/cleff.cabal @@ -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 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.* diff --git a/src/Cleff/Error.hs b/src/Cleff/Error.hs --- a/src/Cleff/Error.hs +++ b/src/Cleff/Error.hs @@ -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 #-} diff --git a/src/Cleff/Internal.hs b/src/Cleff/Internal.hs --- a/src/Cleff/Internal.hs +++ b/src/Cleff/Internal.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Base.hs b/src/Cleff/Internal/Base.hs --- a/src/Cleff/Internal/Base.hs +++ b/src/Cleff/Internal/Base.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Interpret.hs b/src/Cleff/Internal/Interpret.hs --- a/src/Cleff/Internal/Interpret.hs +++ b/src/Cleff/Internal/Interpret.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Monad.hs b/src/Cleff/Internal/Monad.hs --- a/src/Cleff/Internal/Monad.hs +++ b/src/Cleff/Internal/Monad.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Rec.hs b/src/Cleff/Internal/Rec.hs --- a/src/Cleff/Internal/Rec.hs +++ b/src/Cleff/Internal/Rec.hs @@ -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 diff --git a/src/Cleff/Internal/TH.hs b/src/Cleff/Internal/TH.hs --- a/src/Cleff/Internal/TH.hs +++ b/src/Cleff/Internal/TH.hs @@ -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 diff --git a/src/Cleff/Internal/ThreadVar.hs b/src/Cleff/Internal/ThreadVar.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/ThreadVar.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Vec.hs b/src/Cleff/Internal/Vec.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Vec.hs @@ -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 diff --git a/src/Cleff/State.hs b/src/Cleff/State.hs --- a/src/Cleff/State.hs +++ b/src/Cleff/State.hs @@ -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. -- diff --git a/test/ConcurrencySpec.hs b/test/ConcurrencySpec.hs --- a/test/ConcurrencySpec.hs +++ b/test/ConcurrencySpec.hs @@ -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