diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Changelog for `primal` +## 0.3.0 + +* Addition of `eval`, `evalM`, `deepeval` and `deepevalM` +* Addittion of `whenM` and `unlessM` +* Whole bunch of concurrency and exception functionality +* Addition of `Ref` adnd `MVar` +* Addition of basic array functionality: + * Boxed array `BArray` and `BMArray` + * Small boxed array `SBArray` and `SBMArray` + * Unboxed array `UArray` and `UMArray` +* Move `Size` into `Data.Prim.Array` module +* Fix byte offset reading/writing compat functions for `Float`, `Double`, `Int16` and + `Int32` for pre ghc-8.6 +* Fix alignemnt for `()`, `Complex`, `Ratio` and `Fingerprint` +* Addition of internal to base function: `(#.)` + ## 0.2.0 * Addition of `offToCount`, `offForType`, `countToOff` and `countForType` diff --git a/bench/MVar.hs b/bench/MVar.hs new file mode 100644 --- /dev/null +++ b/bench/MVar.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import qualified Control.Concurrent.MVar as Base +import Control.Prim.Concurrent.MVar +import Control.Prim.Eval +import Control.Prim.Monad +import Criterion.Main +import Data.Coerce +import qualified Data.IORef as Base +import Data.Prim.Ref +import qualified UnliftIO.MVar as Unlift +import Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_) + +main :: IO () +main = do + let !i0 = 16 :: Integer + !i1 = 17 :: Integer + envRef :: NFData e => e -> (Ref e RW -> Benchmark) -> Benchmark + envRef e g = e `deepseq` env (BNF <$> newRef e) $ \ref -> g (coerce ref) + envIORef :: NFData e => e -> (Base.IORef e -> Benchmark) -> Benchmark + envIORef e g = + e `deepseq` env (BNF <$> Base.newIORef e) $ \ref -> g (coerce ref) + envMVar :: (NFData e) => e -> (MVar e RW -> Benchmark) -> Benchmark + envMVar e g = e `deepseq` env (BNF <$> newMVar e) $ \(BNF var) -> g var + envBaseMVar :: (NFData e) => e -> (Base.MVar e -> Benchmark) -> Benchmark + envBaseMVar e g = + e `deepseq` env (BNF <$> Base.newMVar e) $ \(BNF var) -> g var + defaultMain + [ bgroup + "Int" + [ bgroup + "new" + [ bench "newRef" $ whnfIO $ newRef i0 + , bench "newIORef (base)" $ whnfIO $ Base.newIORef i0 + , bench "newEmptyMVar" $ whnfIO newEmptyMVar + , bench "newEmptyMVar (base)" $ whnfIO Base.newEmptyMVar + , bench "newEmptyMVar (unliftio)" $ whnfIO Unlift.newEmptyMVar + , bench "newMVar" $ whnfIO $ newMVar i0 + , bench "newMVar (base)" $ whnfIO $ Base.newMVar i0 + , bench "newMVar (unliftio)" $ whnfIO $ Unlift.newMVar i0 + ] + , bgroup + "read" + [ envRef i0 $ \ref -> bench "readRef" $ whnfIO $ readRef ref + , envIORef i0 $ \ref -> + bench "readIORef (base)" $ whnfIO $ Base.readIORef ref + , envMVar i0 $ \ref -> bench "readMVar" $ whnfIO $ readMVar ref + , envBaseMVar i0 $ \ref -> + bench "readMVar (base)" $ whnfIO $ Base.readMVar ref + , envBaseMVar i0 $ \ref -> + bench "readMVar (unliftio)" $ whnfIO $ Unlift.readMVar ref + ] + , bgroup + "write" + [ envRef i0 $ \ref -> bench "writeRef" $ whnfIO $ writeRef ref i1 + , envIORef i0 $ \ref -> + bench "writeIORef" $ whnfIO $ Base.writeIORef ref i1 + , envMVar i0 $ \ref -> bench "writeMVar" $ whnfIO $ writeMVar ref i1 + ] + , bgroup + "modify" + [ envRef i0 $ \ref -> + bench "modifyRef_" $ whnfIO $ modifyRef_ ref (+ i1) + , envIORef i0 $ \ref -> + bench "modifyIORef' (base)" $ + whnfIO $ Base.modifyIORef' ref (+ i1) + , envMVar i0 $ \ref -> + bench "modifyMVar_" $ whnfIO $ modifyMVar_ ref (pure . (+ i1)) + , envBaseMVar i0 $ \ref -> + bench "modifyMVar_ (base)" $ + whnfIO $ Base.modifyMVar_ ref (pure . (+ i1)) + , envBaseMVar i0 $ \ref -> + bench "modifyMVar_ (unliftio)" $ + whnfIO $ Unlift.modifyMVar_ ref (pure . (+ i1)) + ] + , bgroup + "modifyMVarMasked" + [ envMVar i0 $ \ref -> + bench "modifyMVarMasked_" $ + whnfIO $ modifyMVarMasked_ ref (pure . (+ i1)) + , envBaseMVar i0 $ \ref -> + bench "modifyMVarMasked_ (base)" $ + whnfIO $ Base.modifyMVarMasked_ ref (pure . (+ i1)) + , envBaseMVar i0 $ \ref -> + bench "modifyMVarMasked_ (unliftio)" $ + whnfIO $ Unlift.modifyMVarMasked_ ref (pure . (+ i1)) + ] + ] + , bgroup + "atomicWrite" + [ envRef i0 $ \ref -> + bench "atomicWriteRef" $ whnfIO $ atomicWriteRef ref i1 + , envIORef i0 $ \ref -> + bench "atomicWriteIORef" $ whnfIO $ Base.atomicWriteIORef ref i1 + ] + , bgroup + "atomicModify" + [ envRef i0 $ \ref -> + bench "atomicModifyRef" $ + whnfIO $ atomicModifyRef ref $ \x -> (x + i1, x) + , envIORef i0 $ \ref -> + bench "atomicModifyIORefCAS" $ + whnfIO $ atomicModifyIORefCAS ref $ \x -> (x + i1, x) + , envIORef i0 $ \ref -> + bench "atomicModifyIORef'" $ + whnfIO $ Base.atomicModifyIORef' ref $ \x -> (x + i1, x) + ] + , bgroup + "atomicModify_" + [ envRef i0 $ \ref -> + bench "atomicModifyRef_" $ whnfIO $ atomicModifyRef_ ref (+ i1) + , envIORef i0 $ \ref -> + bench "atomicModifyIORefCAS_" $ + whnfIO $ atomicModifyIORefCAS_ ref (+ i1) + , envIORef i0 $ \ref -> + bench "atomicModifyIORef'" $ + whnfIO $ Base.atomicModifyIORef' ref $ \x -> (x + i1, ()) + ] + ] diff --git a/cbits/primal_compat.c b/cbits/primal_compat.c --- a/cbits/primal_compat.c +++ b/cbits/primal_compat.c @@ -25,6 +25,23 @@ *((HsWord64 *)(ptr + offset)) = x; } + +HsFloat primal_memread_float(const HsWord8 *ptr, HsInt offset){ + return *((HsFloat *)(ptr + offset)); +} +void primal_memwrite_float(HsWord8 *ptr, HsInt offset, HsFloat x){ + *((HsFloat *)(ptr + offset)) = x; +} + +HsDouble primal_memread_double(const HsWord8 *ptr, HsInt offset){ + return *((HsDouble *)(ptr + offset)); +} +void primal_memwrite_double(HsWord8 *ptr, HsInt offset, HsDouble x){ + *((HsDouble *)(ptr + offset)) = x; +} + + + #if __GLASGOW_HASKELL__ < 802 /** * Rewrite of some Cmm in C. It is not in Cmm because `bdescr_flags` is not available diff --git a/cbits/primal_stg.cmm b/cbits/primal_stg.cmm --- a/cbits/primal_stg.cmm +++ b/cbits/primal_stg.cmm @@ -16,6 +16,11 @@ #define TO_ZXW_(x) %zx64(x) #endif +// macro was changed in ghc-9 +#ifndef OVERWRITING_CLOSURE_OFS +#define OVERWRITING_CLOSURE_OFS(c,n) OVERWRITING_CLOSURE_MUTABLE(c,n) +#endif + primal_stg_word64ToDoublezh(I64 w) { D_ d; @@ -75,4 +80,33 @@ } return (w); +} + + +// shrink size of MutableArray in-place +primal_stg_shrinkMutableArrayzh ( gcptr arr, W_ new_size ) +// MutableArray# s a -> Int# -> State# s -> State# s +{ + ASSERT(new_size <= StgMutArrPtrs_ptrs(mba)); + + + OVERWRITING_CLOSURE_OFS(arr, (BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + + new_size)); + StgMutArrPtrs_ptrs(arr) = new_size; + + return (new_size); +} + + +// shrink size of SmallMutableArray in-place +primal_stg_shrinkSmallMutableArrayzh ( gcptr arr, W_ new_size ) +// SmallMutableArray# s a -> Int# -> State# s -> State# s +{ + ASSERT(new_size <= StgSmallMutArrPtrs_ptrs(arr)); + + OVERWRITING_CLOSURE_OFS(arr, (BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + + new_size)); + StgSmallMutArrPtrs_ptrs(arr) = new_size; + + return (new_size); } diff --git a/primal.cabal b/primal.cabal --- a/primal.cabal +++ b/primal.cabal @@ -1,5 +1,5 @@ name: primal -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Primeval world of Haskell. description: Please see the README on GitHub at homepage: https://github.com/lehins/primal @@ -13,27 +13,36 @@ extra-source-files: README.md , CHANGELOG.md cabal-version: 1.18 -tested-with: GHC == 8.4.3 +tested-with: GHC == 7.10.2 + , GHC == 7.10.3 + , GHC == 8.0.1 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.3 , GHC == 8.4.4 , GHC == 8.6.3 , GHC == 8.6.4 , GHC == 8.6.5 - , GHC == 8.8.1 , GHC == 8.8.2 + , GHC == 8.8.3 + , GHC == 8.8.4 , GHC == 8.10.1 library hs-source-dirs: src exposed-modules: Control.Prim.Concurrent + , Control.Prim.Concurrent.MVar , Control.Prim.Eval , Control.Prim.Exception , Control.Prim.Monad , Control.Prim.Monad.Throw , Control.Prim.Monad.Unsafe , Data.Prim + , Data.Prim.Array , Data.Prim.Atom , Data.Prim.Atomic , Data.Prim.Class + , Data.Prim.Ref , Data.Prim.StableName , Foreign.Prim , Foreign.Prim.Ptr @@ -46,9 +55,10 @@ , Foreign.Prim.C.LtGHC802 , Foreign.Prim.C.LtGHC806 , Foreign.Prim.Cmm - build-depends: base >= 4.8 && < 5 + build-depends: base >= 4.8.1 && < 5 + , array >= 0.1 , deepseq - , transformers + , transformers >= 0.4.2.0 default-language: Haskell2010 ghc-options: -Wall @@ -81,6 +91,46 @@ default-language: Haskell2010 ghc-options: -Wall -threaded + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Spec + , Test.Prim.ArraySpec + , Test.Prim.MVarSpec + , Test.Prim.RefSpec + build-depends: base + , bytestring + , deepseq + , primal + , hspec + , QuickCheck + , quickcheck-classes-base + + default-language: Haskell2010 + ghc-options: -Wall + -fno-warn-orphans + -threaded + -with-rtsopts=-N2 + if !impl(ghc < 8.0) + ghc-options: -fno-warn-redundant-constraints + + +benchmark mvar + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: MVar.hs + ghc-options: -Wall + -threaded + -O2 + -with-rtsopts=-N4 + build-depends: base + , criterion + , primal + , unliftio + , atomic-primops + default-language: Haskell2010 source-repository head diff --git a/src/Control/Prim/Concurrent.hs b/src/Control/Prim/Concurrent.hs --- a/src/Control/Prim/Concurrent.hs +++ b/src/Control/Prim/Concurrent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} @@ -13,17 +14,45 @@ -- Portability : non-portable -- module Control.Prim.Concurrent - ( module Control.Prim.Concurrent + ( GHC.ThreadId(..) + , fork + , forkFinally + , forkOn + , forkOnFinally + , forkOS + , killThread + , yield + + , threadDelay + , timeout + , timeout_ + + , myThreadId + , threadIdToCInt + , threadStatus + , labelThread + , isCurrentThreadBound + , threadCapability + , getNumCapabilities + , setNumCapabilities + -- * Sparks + , spark + , numSparks + , runSparks + -- * Single threaded RTS + , delay + , waitRead + , waitWrite + , module Control.Prim.Monad ) where import qualified Control.Exception as GHC -import qualified GHC.Conc as GHC +import qualified Control.Concurrent as GHC import Control.Prim.Exception -import Control.Prim.Monad.Internal -import GHC.Exts -import System.Posix.Types -import Foreign.C.Types - +import Control.Prim.Monad +import Foreign.Prim +import qualified GHC.Conc as GHC +import qualified System.Timeout as GHC spark :: MonadPrim s m => a -> m a spark a = prim (spark# a) @@ -50,46 +79,89 @@ delay (I# i#) = prim_ (delay# i#) -- | Wrapper for `waitRead#`. Block and wait for input to become available on the --- `Fd`. Not designed for threaded runtime: __Errors when compiled with @-threaded@__ +-- `Fd`. Not designed for threaded runtime: __Errors out when compiled with @-threaded@__ waitRead :: MonadPrim s m => Fd -> m () -waitRead fd = +waitRead !fd = case fromIntegral fd of I# i# -> prim_ (waitRead# i#) -- | Wrapper for `waitWrite#`. Block and wait until output is possible on the `Fd`. --- Not designed for threaded runtime: __Errors when compiled with @-threaded@__ +-- Not designed for threaded runtime: __Errors out when compiled with @-threaded@__ waitWrite :: MonadPrim s m => Fd -> m () -waitWrite fd = +waitWrite !fd = case fromIntegral fd of I# i# -> prim_ (waitWrite# i#) -- | Wrapper around `fork#`. Unlike `Control.Concurrent.forkIO` it does not install -- any exception handlers on the action, so you need make sure to do it yourself. -fork :: MonadPrim RW m => m () -> m GHC.ThreadId +fork :: MonadUnliftPrim RW m => m () -> m GHC.ThreadId fork action = - prim $ \s -> - case fork# action s of + runInPrimBase action $ \action# s -> + case fork# (IO action#) s of (# s', tid# #) -> (# s', GHC.ThreadId tid# #) +-- | Spawn a thread and run an action in it. Any exception raised by the new thread will +-- be passed to the supplied exception handler, which itself will be run in a masked state +forkFinally :: MonadUnliftPrim RW m => m a -> (Either SomeException a -> m ()) -> m GHC.ThreadId +forkFinally action handler = + mask $ \restore -> fork $ tryAny (restore action) >>= handler + -- | Wrapper around `forkOn#`. Unlike `Control.Concurrent.forkOn` it does not install any -- exception handlers on the action, so you need make sure to do it yourself. -forkOn :: MonadPrim RW m => Int -> m () -> m GHC.ThreadId +forkOn :: MonadUnliftPrim RW m => Int -> m () -> m GHC.ThreadId forkOn (I# cap#) action = - prim $ \s -> - case forkOn# cap# action s of + runInPrimBase action $ \action# s -> + case forkOn# cap# (IO action#) s of (# s', tid# #) -> (# s', GHC.ThreadId tid# #) +forkOnFinally :: + MonadUnliftPrim RW m + => Int + -> m a + -> (Either SomeException a -> m ()) + -> m GHC.ThreadId +forkOnFinally cap action handler = + mask $ \restore -> forkOn cap $ tryAny (restore action) >>= handler + + +forkOS :: MonadUnliftPrim RW m => m () -> m GHC.ThreadId +forkOS action = withRunInIO $ \run -> GHC.forkOS (run action) + + + -- | Wrapper around `killThread#`, which throws `GHC.ThreadKilled` exception in the target -- thread. Use `throwTo` if you want a different exception to be thrown. killThread :: MonadPrim RW m => GHC.ThreadId -> m () -killThread tid = throwTo tid GHC.ThreadKilled +killThread !tid = throwTo tid GHC.ThreadKilled +-- | Lifted version of `GHC.threadDelay` +threadDelay :: MonadPrim RW m => Int -> m () +threadDelay = liftIO . GHC.threadDelay --- | Wrapper around `yield#`. -yield :: MonadPrim RW m => m () -yield = prim_ yield# +-- | Lifted version of `GHC.timeout` +-- +-- @since 0.3.0 +timeout :: MonadUnliftPrim RW m => Int -> m a -> m (Maybe a) +timeout !n !action = withRunInIO $ \run -> GHC.timeout n (run action) +-- | Same as `timeout`, but ignores the outcome +-- +-- @since 0.3.0 +timeout_ :: MonadUnliftPrim RW m => Int -> m a -> m () +timeout_ n = void . timeout n + + + +-- | Just like `Control.Concurrent.yield` this is a Wrapper around `yield#` primop , +-- except that this version works for any state token. It is safe to use within `ST` +-- because it can't affect the result of computation, just the order of evaluation with +-- respect to other threads, which is not relevant for the state thread monad anyways. +-- +-- @since 0.3.0 +yield :: forall m s. MonadPrim s m => m () +yield = prim_ (unsafeCoerce# yield# :: State# s -> State# s) + -- | Wrapper around `myThreadId#`. myThreadId :: MonadPrim RW m => m GHC.ThreadId myThreadId = @@ -101,8 +173,11 @@ labelThread :: MonadPrim RW m => GHC.ThreadId -> Ptr a -> m () labelThread (GHC.ThreadId tid#) (Ptr addr#) = prim_ (labelThread# tid# addr#) -isCurrentThreadBoundPrim :: MonadPrim RW m => m Bool -isCurrentThreadBoundPrim = +-- | Check if current thread was spawned with `forkOn#` +-- +-- @since 0.3.0 +isCurrentThreadBound :: MonadPrim RW m => m Bool +isCurrentThreadBound = prim $ \s -> case isCurrentThreadBound# s of (# s', bool# #) -> (# s', isTrue# bool# #) @@ -113,7 +188,15 @@ threadCapability :: MonadPrim RW m => GHC.ThreadId -> m (Int, Bool) threadCapability = liftPrimBase . GHC.threadCapability --- | Something that is not available in @base@. Convert a `GHC.ThreadId` to a regular +getNumCapabilities :: MonadPrim RW m => m Int +getNumCapabilities = liftPrimBase GHC.getNumCapabilities + +setNumCapabilities :: MonadPrim RW m => Int -> m () +setNumCapabilities = liftPrimBase . GHC.setNumCapabilities + + + +-- | Something that is not exported from @base@: convert a `GHC.ThreadId` to a regular -- integral type. -- -- @since 0.0.0 diff --git a/src/Control/Prim/Concurrent/MVar.hs b/src/Control/Prim/Concurrent/MVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Prim/Concurrent/MVar.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Control.Prim.Concurrent.MVar +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Control.Prim.Concurrent.MVar + ( -- * MVar + MVar(..) + , isEmptyMVar + , isSameMVar + -- ** Create + , newMVar + , newLazyMVar + , newDeepMVar + , newEmptyMVar + -- ** Write + , putMVar + , putLazyMVar + , putDeepMVar + , tryPutMVar + , tryPutLazyMVar + , tryPutDeepMVar + , writeMVar + -- ** Read + , readMVar + , tryReadMVar + , takeMVar + , tryTakeMVar + , clearMVar + -- ** Modify + , swapMVar + , swapLazyMVar + , swapDeepMVar + , withMVar + , withMVarMasked + , modifyMVar_ + , modifyMVarMasked_ + , modifyFetchOldMVar + , modifyFetchOldMVarMasked + , modifyFetchNewMVar + , modifyFetchNewMVarMasked + , modifyMVar + , modifyMVarMasked + -- ** Weak Pointer + , mkWeakMVar + -- ** Conversion + , toBaseMVar + , fromBaseMVar + ) where + +import Control.DeepSeq +import Control.Prim.Monad +import Control.Prim.Exception +import GHC.Exts +import GHC.Weak +import qualified GHC.MVar as GHC + +-- | Mutable variable that can either be empty or full. Same as +-- `Control.Concurrent.MVar.MVar`, but works with any state token therefore it is also +-- usable within `ST` monad. +-- +-- @since 0.3.0 +data MVar a s = MVar (MVar# s a) + +-- | Calls `isSameMVar` +instance Eq (MVar a s) where + (==) = isSameMVar + {-# INLINE (==) #-} + + +-- | Checks whether supplied `MVar`s refer to the exact same one. +-- +-- @since 0.3.0 +isSameMVar :: forall a s. MVar a s -> MVar a s -> Bool +isSameMVar (MVar mvar1#) (MVar mvar2#) = isTrue# (sameMVar# mvar1# mvar2#) +{-# INLINE isSameMVar #-} + +-- | Checks whether supplied `MVar` is empty. +-- +-- @since 0.3.0 +isEmptyMVar :: forall a m s. MonadPrim s m => MVar a s -> m Bool +isEmptyMVar (MVar mvar#) = + prim $ \s -> + case isEmptyMVar# mvar# s of + (# s', isEmpty# #) -> (# s', isTrue# isEmpty# #) +{-# INLINE isEmptyMVar #-} + + +-- | Construct an `MVar` with initial value in it, which is evaluated to WHNF +-- +-- @since 0.3.0 +newMVar :: forall a m s. MonadPrim s m => a -> m (MVar a s) +newMVar a = newEmptyMVar >>= \mvar -> mvar <$ putMVar mvar a +{-# INLINE newMVar #-} + +-- | Construct an `MVar` with initial value in it. +-- +-- Same as `Control.Concurrent.MVar.newMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +newLazyMVar :: forall a m s. MonadPrim s m => a -> m (MVar a s) +newLazyMVar a = newEmptyMVar >>= \mvar -> mvar <$ putLazyMVar mvar a +{-# INLINE newLazyMVar #-} + + +-- | Construct an `MVar` with initial value in it. +-- +-- @since 0.3.0 +newDeepMVar :: forall a m s. (NFData a, MonadPrim s m) => a -> m (MVar a s) +newDeepMVar a = newEmptyMVar >>= \mvar -> mvar <$ putDeepMVar mvar a +{-# INLINE newDeepMVar #-} + + +-- | Construct an empty `MVar`. +-- +-- Same as `Control.Concurrent.MVar.newEmptyMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +newEmptyMVar :: forall a m s. MonadPrim s m => m (MVar a s) +newEmptyMVar = + prim $ \s -> + case newMVar# s of + (# s', mvar# #) -> (# s', MVar mvar# #) +{-# INLINE newEmptyMVar #-} + + +-- | Write a value into an `MVar`. Blocks the current thread if `MVar` is empty and waits +-- until it gets filled by another thread. Evaluates the argument to WHNF prior to writing +-- it. +-- +-- @since 0.3.0 +putMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m () +putMVar mvar x = putLazyMVar (x `seq` mvar) x +{-# INLINE putMVar #-} + + +-- | Same as `putMVar`, but allows to write a thunk into an MVar. +-- +-- Same as `Control.Concurrent.MVar.putMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +putLazyMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m () +putLazyMVar (MVar mvar#) x = prim_ (putMVar# mvar# x) +{-# INLINE putLazyMVar #-} + + +-- | Same as putMVar, but evaluates the argument to NF prior to writing it. +-- +-- @since 0.3.0 +putDeepMVar :: forall a m s. (NFData a, MonadPrim s m) => MVar a s -> a -> m () +putDeepMVar mvar x = putLazyMVar (x `deepseq` mvar) x +{-# INLINE putDeepMVar #-} + + +-- | Attempt to write a value into `MVar`. Unlike `putMVar` this function never blocks. It +-- also returns `True` if `MVar` was empty and placing the value in it turned out to be +-- successfull and `False` otherwise. Evaluates the supplied argumetn to WHNF prior to +-- attempting a write operation. +-- +-- @since 0.3.0 +tryPutMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m Bool +tryPutMVar mvar x = tryPutLazyMVar (x `seq` mvar) x +{-# INLINE tryPutMVar #-} + +-- | Same as `tryPutMVar`, but allows to put thunks into an `MVar` +-- +-- Same as `Control.Concurrent.MVar.tryPutMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +tryPutLazyMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m Bool +tryPutLazyMVar (MVar mvar#) x = + prim $ \s -> + case tryPutMVar# mvar# x s of + (# s', b# #) -> (# s', isTrue# b# #) +{-# INLINE tryPutLazyMVar #-} + + +-- | Same as `tryPutMVar`, but evaluates the argument to NF prior to attempting to write +-- into the `MVar` +-- +-- @since 0.3.0 +tryPutDeepMVar :: forall a m s. (NFData a, MonadPrim s m) => MVar a s -> a -> m Bool +tryPutDeepMVar mvar x = tryPutLazyMVar mvar $! force x +{-# INLINE tryPutDeepMVar #-} + + +-- | Write a value into the MVar regardless if it is currently empty or not. If there is a +-- currently a value it will in the MVar it will simply b discarded. However, if there is +-- another thread that is blocked on attempt to write into this MVar, current operation +-- will block on attempt to fill the MVar. Therefore `writeMVar` is not atomic. Argument +-- is evaluated to WHNF prior to clearing the contents of `MVar` +-- +-- @since 0.3.0 +writeMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m () +writeMVar mvar a = + maskPrimBase_ $ do + clearMVar (a `seq` mvar) + putLazyMVar mvar a :: ST s () +{-# INLINE writeMVar #-} + + +-- | Replace current value in an `MVar` with a new one. Supplied value is evaluated to +-- WHNF prior to current value being extracted from the `MVar`. If `MVar` is currently +-- empty this operation will block the current thread until it gets filled in another +-- thread. Furthermore it is possible for another thread to fill the `MVar` after the old +-- value is extracted, but before the new one has a chance to placed inside the `MVar`, +-- thus blocking current thread once more until another thread empties this `MVar`. In +-- other words this operation is not atomic. +-- +-- @since 0.3.0 +swapMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m a +swapMVar mvar new = + maskPrimBase_ $ do + old <- takeMVar (new `seq` mvar) + old <$ (putLazyMVar mvar new :: ST s ()) +{-# INLINE swapMVar #-} + +-- | Same as `swapMVar`, but allows writing thunks into the `MVar`. +-- +-- Same as `Control.Concurrent.MVar.swapMVar` from @base@, but works in any `MonadUnliftPrim`. +-- +-- @since 0.3.0 +swapLazyMVar :: forall a m s. MonadPrim s m => MVar a s -> a -> m a +swapLazyMVar mvar new = + maskPrimBase_ $ do + old <- takeMVar mvar + old <$ (putLazyMVar mvar new :: ST s ()) +{-# INLINE swapLazyMVar #-} + + +-- | Same as `swapMVar`, but evaluates the argument value to NF. +-- +-- @since 0.3.0 +swapDeepMVar :: forall a m s. (NFData a, MonadPrim s m) => MVar a s -> a -> m a +swapDeepMVar mvar new = + maskPrimBase_ $ do + old <- takeMVar (new `deepseq` mvar) + old <$ (putLazyMVar mvar new :: ST s ()) +{-# INLINE swapDeepMVar #-} + + +-- | Remove the value from `MVar` and return it. Blocks the cuurent thread if `MVar` is empty and +-- waits until antoher thread fills it. +-- +-- Same as `Control.Concurrent.MVar.takeMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +takeMVar :: forall a m s. MonadPrim s m => MVar a s -> m a +takeMVar (MVar mvar#) = prim $ \ s# -> takeMVar# mvar# s# +{-# INLINE takeMVar #-} + + + +-- | Remove the value from `MVar` and return it immediately without blocking. `Nothing` is +-- returned if `MVar` was empty. +-- +-- Same as `Control.Concurrent.MVar.tryTakeMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +tryTakeMVar :: forall a m s. MonadPrim s m => MVar a s -> m (Maybe a) +tryTakeMVar (MVar mvar#) = + prim $ \s -> + case tryTakeMVar# mvar# s of + (# s', 0#, _ #) -> (# s', Nothing #) + (# s', _, a #) -> (# s', Just a #) +{-# INLINE tryTakeMVar #-} + +-- | Get the value from `MVar` atomically without affecting its contents. Blocks the +-- current thread if the `MVar` is currently empty and waits until another thread fills +-- it with a value. +-- +-- Same as `Control.Concurrent.MVar.readMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +readMVar :: forall a m s. MonadPrim s m => MVar a s -> m a +readMVar (MVar mvar#) = prim (readMVar# mvar#) +{-# INLINE readMVar #-} + + +-- | Get the value from `MVar` atomically without affecting its contents. It does not +-- block and returns the immediately or `Nothing` if the supplied `MVar` was empty. +-- +-- Same as `Control.Concurrent.MVar.tryReadMVar` from @base@, but works in any `MonadPrim`. +-- +-- @since 0.3.0 +tryReadMVar :: forall a m s. MonadPrim s m => MVar a s -> m (Maybe a) +tryReadMVar (MVar mvar#) = + prim $ \s -> + case tryReadMVar# mvar# s of + (# s', 0#, _ #) -> (# s', Nothing #) + (# s', _, a #) -> (# s', Just a #) +{-# INLINE tryReadMVar #-} + +-- | Remove a value from an `MVar`, unless it was already empty. It effectively empties +-- the `MVar` however note that by the time this action returns there is a possibility +-- that another thread might have filled it with a different value. +-- +-- @since 0.3.0 +clearMVar :: forall a m s. MonadPrim s m => MVar a s -> m () +clearMVar (MVar mvar#) = + prim $ \s -> + case tryTakeMVar# mvar# s of + (# s', _, _ #) -> (# s', () #) +{-# INLINE clearMVar #-} + + +-- | Apply an action to the contents of an `MVar`. Current thread will be blocked if +-- supplied MVar is empty and will wait until another thread fills it with a value. While +-- the action is being appplied other threads should not put anything into the `MVar` +-- otherwise current thread will get blocked again until another thread empties the +-- `MVar`. In other words this is not an atomic operation, but it is exception safe, since +-- the contents of `MVar` are restored regardless of the outcome of supplied action. +-- +-- Same as `Control.Concurrent.MVar.withMVar` from @base@, but works in `MonadUnliftPrim` +-- with `RealWorld` state token. +-- +-- @since 0.3.0 +withMVar :: forall a b m. MonadUnliftPrim RW m => MVar a RW -> (a -> m b) -> m b +withMVar mvar !action = + mask $ \restore -> do + a <- takeMVar mvar + b <- restore (action a) `catchAny` \exc -> putLazyMVar mvar a >> throw exc + b <$ putLazyMVar mvar a +{-# INLINE withMVar #-} + + +-- | Same as `withMVar`, but with supplied action executed with async exceptions masked, +-- but still interruptable. +-- +-- Same as `Control.Concurrent.MVar.withMVarMasked` from @base@, but works in +-- `MonadUnliftPrim` with `RealWorld` state token. +-- +-- @since 0.3.0 +withMVarMasked :: forall a b m. MonadUnliftPrim RW m => MVar a RW -> (a -> m b) -> m b +withMVarMasked mvar !action = + mask_ $ do + a <- takeMVar mvar + b <- action a `catchAny` \exc -> putLazyMVar mvar a >> throw exc + b <$ putLazyMVar mvar a +{-# INLINE withMVarMasked #-} + + + + +-- | Internal modification function that does no masking or forcing +modifyFetchLazyMVar :: MonadUnliftPrim RW m => (a -> a -> b) -> MVar a RW -> (a -> m a) -> m b +modifyFetchLazyMVar select mvar action = do + a <- takeMVar mvar + a' <- action a `catchAny` \exc -> putLazyMVar mvar a >> throw exc + select a a' <$ putLazyMVar mvar a' +{-# INLINE modifyFetchLazyMVar #-} + + +-- | Apply a monadic action to the contents of supplied `MVar`. Provides the same +-- guarantees as `withMVar`. +-- +-- Same as `GHC.modifyMVar_` from @base@, but is strict with respect to result of the +-- action and works in `MonadUnliftPrim` with `RealWorld` state token. +-- +-- @since 0.3.0 +modifyMVar_ :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m () +modifyMVar_ mvar = void . modifyFetchOldMVar mvar +{-# INLINE modifyMVar_ #-} + + +-- | Same as `modifyMVarMAsked_`, but the supplied action has async exceptions masked. +-- +-- Same as `GHC.modifyMVar` from @base@, except that it is strict in the new value and it +-- works in `MonadUnliftPrim` with `RealWorld` state token. +-- +-- @since 0.3.0 +modifyMVarMasked_ :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m () +modifyMVarMasked_ mvar !action = + mask_ $ modifyFetchLazyMVar (\_ _ -> ()) mvar (action >=> \a' -> pure $! a') +{-# INLINE modifyMVarMasked_ #-} + + +-- | Same as `modifyMVar_`, but also returns the original value that was stored in the `MVar` +-- +-- @since 0.3.0 +modifyFetchOldMVar :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m a +modifyFetchOldMVar mvar !action = + mask $ \restore -> + modifyFetchLazyMVar const mvar $ \a -> + restore (action a >>= \a' -> pure $! a') +{-# INLINE modifyFetchOldMVar #-} + + + +-- | Same as `modifyFetchOldMVar`, but supplied action will run with async exceptions +-- masked, but still interruptible +-- +-- @since 0.3.0 +modifyFetchOldMVarMasked :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m a +modifyFetchOldMVarMasked mvar !action = + mask_ $ modifyFetchLazyMVar const mvar (action >=> \a' -> pure $! a') +{-# INLINE modifyFetchOldMVarMasked #-} + +-- | Same as `modifyMVar_`, but also returns the result of running the supplied action, +-- i.e. the new value that got stored in the `MVar`. +-- +-- @since 0.3.0 +modifyFetchNewMVar :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m a +modifyFetchNewMVar mvar !action = + mask $ \restore -> + modifyFetchLazyMVar (flip const) mvar $ \a -> + restore (action a >>= \a' -> pure $! a') +{-# INLINE modifyFetchNewMVar #-} + + +-- | Same as `modifyFetchNewMVar`, but supplied action will run with async exceptions +-- masked, but still interruptible +-- +-- @since 0.3.0 +modifyFetchNewMVarMasked :: forall a m. MonadUnliftPrim RW m => MVar a RW -> (a -> m a) -> m a +modifyFetchNewMVarMasked mvar !action = + mask_ $ modifyFetchLazyMVar (flip const) mvar (action >=> \a' -> pure $! a') +{-# INLINE modifyFetchNewMVarMasked #-} + + + +-- | Apply a monadic action to the contents of supplied `MVar`. Provides the same +-- guarantees as `withMVar`. +-- +-- Same as `GHC.modifyMVar` from @base@, except that it is strict in the new value and it +-- works in `MonadUnliftPrim` with `RealWorld` state token. +-- +-- @since 0.3.0 +modifyMVar :: forall a b m. MonadUnliftPrim RW m => MVar a RW -> (a -> m (a, b)) -> m b +modifyMVar mvar action = + mask $ \restore -> do + a <- takeMVar mvar + let run = restore (action a >>= \t@(!_, _) -> pure t) + -- TODO: test against `force a'` + (a', b) <- run `catchAny` \exc -> putLazyMVar mvar a >> throw exc + b <$ putLazyMVar mvar a' +{-# INLINE modifyMVar #-} + + +-- | Apply a monadic action to the contents of supplied `MVar`. Provides the same +-- guarantees as `withMVar`. +-- +-- Same as `GHC.modifyMVarMasked` from @base@, except that it is strict in the new value +-- and it works in `MonadUnliftPrim` with `RealWorld` state token. +-- +-- @since 0.3.0 +modifyMVarMasked :: forall a b m. MonadUnliftPrim RW m => MVar a RW -> (a -> m (a, b)) -> m b +modifyMVarMasked mvar action = + mask_ $ do + a <- takeMVar mvar + let run = action a >>= \t@(!_, _) -> pure t + -- TODO: test against `force a'` + (a', b) <- run `catchAny` \exc -> putLazyMVar mvar a >> throw exc + b <$ putLazyMVar mvar a' +{-# INLINE modifyMVarMasked #-} + + +-- | Create a `Weak` pointer associated with the supplied `MVar`. +-- +-- Same as `Control.Concurrent.MVar.mkWeakMVar` from @base@, but works in any `MonadPrim` +-- with `RealWorld` state token. +-- +-- @since 0.3.0 +mkWeakMVar :: + forall a b m. MonadUnliftPrim RW m + => MVar a RW + -> m b -- ^ An action that will get executed whenever `MVar` gets garbage collected by + -- the runtime. + -> m (Weak (MVar a RW)) +mkWeakMVar mvar@(MVar mvar#) !finalizer = + runInPrimBase finalizer $ \f# s -> + case mkWeak# mvar# mvar f# s of + (# s', weak# #) -> (# s', Weak weak# #) +{-# INLINE mkWeakMVar #-} + + + +-- | Cast `MVar` into and the `Control.Concurrent.MVar.MVar` from @base@ +-- +-- @since 0.3.0 +toBaseMVar :: MVar a RW -> GHC.MVar a +toBaseMVar (MVar mvar#) = GHC.MVar mvar# +{-# INLINE toBaseMVar #-} + +-- | Cast `Control.Concurrent.MVar.MVar` from @base@ into `MVar`. +-- +-- @since 0.3.0 +fromBaseMVar :: GHC.MVar a -> MVar a RW +fromBaseMVar (GHC.MVar mvar#) = MVar mvar# +{-# INLINE fromBaseMVar #-} diff --git a/src/Control/Prim/Eval.hs b/src/Control/Prim/Eval.hs --- a/src/Control/Prim/Eval.hs +++ b/src/Control/Prim/Eval.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,15 +13,33 @@ -- Portability : non-portable -- module Control.Prim.Eval - ( module Control.Prim.Eval + ( -- * Liveness + touch + , touch# + , keepAlive + , keepAlive# + -- * Weak-Head Normal Form + , seq + , eval + , evalM + -- * Normal Form + , deepeval + , deepevalM + , module Control.DeepSeq + , BNF(..) ) where +import Control.DeepSeq import Control.Prim.Monad.Internal -import Control.Prim.Monad.Unsafe -import GHC.Exts +import qualified GHC.Exts as GHC +-- | Same as `GHC.Exts.touch#`, except it is not restricted to `RealWorld` state token. +touch# :: a -> GHC.State# s -> GHC.State# s +touch# a = GHC.unsafeCoerce# (GHC.touch# a) +{-# INLINE touch# #-} + ------- Evaluation @@ -30,24 +49,17 @@ -- Make sure not to use it after some computation that doesn't return, like after -- `forever` for example, otherwise touch will simply be removed by ghc and bad things -- will happen. If you have a case like that, make sure to use `withAlivePrimBase` or --- `withAliveUnliftPrim` instead. +-- `keepAlive` instead. -- -- @since 0.1.0 touch :: MonadPrim s m => a -> m () -touch x = unsafeIOToPrim $ prim_ (touch# x) +touch x = prim_ (touch# x) {-# INLINE touch #-} --- | An action that evaluates a value to weak head normal form. Same --- as `Control.Exception.evaluate`, except it works in a `MonadPrim` --- --- @since 0.1.0 -seqPrim :: MonadPrim s m => a -> m a -seqPrim a = prim (seq# a) - -- | Forward compatible operator that might be introduced in some future ghc version. -- --- See: [!3131](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3131) +-- See: [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760) -- -- Current version is not as efficient as the version that will be introduced in the -- future, because it works around the ghc bug by simply preventing inlining and relying @@ -57,35 +69,79 @@ keepAlive# :: a -- ^ The value to preserve - -> (State# s -> (# State# s, r #)) + -> (GHC.State# s -> (# GHC.State# s, r #)) -- ^ The continuation in which the value will be preserved - -> State# s - -> (# State# s, r #) + -> GHC.State# s + -> (# GHC.State# s, r #) keepAlive# a m s = case m s of - (# s', r #) -> (# unsafeCoerce# (touch# a) s', r #) + (# s', r #) -> (# touch# a s', r #) {-# NOINLINE keepAlive# #-} --- | Similar to `touch`. See `withAlive#` for more info. --- --- @since 0.1.0 -withAlivePrimBase :: (MonadPrimBase s n, MonadPrim s m) => a - -- ^ The value to preserve - -> n b - -- ^ Action to run in which the value will be preserved - -> m b -withAlivePrimBase a m = prim (keepAlive# a (primBase m)) -{-# INLINE withAlivePrimBase #-} -- | Similar to `touch`. See `withAlive#` for more info. -- --- @since 0.1.0 -withAliveUnliftPrim :: +-- @since 0.3.0 +keepAlive :: MonadUnliftPrim s m => a -- ^ The value to preserve -> m b -- ^ Action to run in which the value will be preserved -> m b -withAliveUnliftPrim a m = runInPrimBase m (keepAlive# a) -{-# INLINE withAliveUnliftPrim #-} +keepAlive a m = runInPrimBase m (keepAlive# a) +{-# INLINE keepAlive #-} + + + +-- | An action that evaluates a value to Weak Head Normal Form (WHNF). Same as +-- `Control.Exception.evaluate`, except it works in `MonadPrim`. This function provides +-- stronger guarantees than `seq` with respect to ordering of operations, but it does have a +-- slightly higher overhead. +-- +-- @since 0.3.0 +eval :: MonadPrim s m => a -> m a +eval a = prim (GHC.seq# a) +{-# INLINE eval #-} + +-- | Run the action and then use `eval` to ensure its result is evaluated to Weak Head +-- Normal Form (WHNF) +-- +-- @since 0.3.0 +evalM :: MonadPrim s m => m a -> m a +evalM m = eval =<< m +{-# INLINE evalM #-} + + +-- Normal Form + + +-- | An action that evaluates a value to Normal Form (NF). This function provides stronger +-- guarantees than `deepseq` with respect to ordering of operations. +-- +-- @since 0.3.0 +deepeval :: (MonadPrim s m, NFData a) => a -> m a +deepeval = eval . force +{-# INLINE deepeval #-} + +-- | Run the action and the using `deepeval` ensure its result is evaluated to Normal Form +-- (NF) +-- +-- @since 0.3.0 +deepevalM :: (MonadPrim s m, NFData a) => m a -> m a +deepevalM m = eval . force =<< m +{-# INLINE deepevalM #-} + + +-- | Bogus Normal Form. This is useful in places where `NFData` constraint is required, +-- but an instance can't really be created in any meaningful way for the type at +-- hand. Creating environment in benchmarks is one such place where it may come in handy. +-- +-- @since 0.3.0 +newtype BNF a = BNF a + +-- | Unlawful instance that only evaluates its contents to WHNF +-- +-- @since 0.3.0 +instance NFData (BNF a) where + rnf (BNF a) = a `seq` () diff --git a/src/Control/Prim/Exception.hs b/src/Control/Prim/Exception.hs --- a/src/Control/Prim/Exception.hs +++ b/src/Control/Prim/Exception.hs @@ -1,132 +1,473 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} --- | --- Module : Control.Prim.Exception --- Copyright : (c) Alexey Kuleshevich 2020 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Control.Prim.Exception - ( module Control.Prim.Monad.Throw - , module Control.Prim.Exception - ) where - -import Control.Prim.Monad.Throw -import Control.Exception as GHC -import qualified GHC.Conc as GHC -import Control.Prim.Monad.Internal -import Control.Prim.Monad.Unsafe -import GHC.Exts - - - ------ Exceptions - -isSyncException :: Exception e => e -> Bool -isSyncException = not . isAsyncException - -isAsyncException :: Exception e => e -> Bool -isAsyncException exc = - case fromException (toException exc) of - Just (SomeAsyncException _) -> True - Nothing -> False - --- | This is the same as `throwM`, but restricted to `MonadPrim` -throwPrim :: (Exception e, MonadPrim s m) => e -> m a -throwPrim e = unsafeIOToPrim $ prim (raiseIO# (toException e)) - -catch :: - forall e a m. (Exception e, MonadUnliftPrim RW m) - => m a - -> (e -> m a) - -> m a -catch action handler = - withRunInPrimBase $ \run -> - let handler# :: SomeException -> (State# RW -> (# State# RW, a #)) - handler# e = - case fromException e of - Just e' -> primBase (run (handler e') :: IO a) - Nothing -> raiseIO# e - in prim (catch# (primBase (run action :: IO a)) handler#) - -catchAny :: - forall a m. MonadUnliftPrim RW m - => m a - -> (SomeException -> m a) - -> m a -catchAny action handler = - withRunInPrimBase $ \run -> - let handler# :: SomeException -> (State# RW -> (# State# RW, a #)) - handler# exc = primBase (run (handler exc) :: IO a) - in prim (catch# (primBase (run action :: IO a)) handler#) - -catchAnySync :: - forall a m. MonadUnliftPrim RW m - => m a - -> (SomeException -> m a) - -> m a -catchAnySync action handler = - withRunInPrimBase $ \run -> - let handler# :: SomeException -> (State# RW -> (# State# RW, a #)) - handler# exc - | isAsyncException exc = raiseIO# exc - | otherwise = primBase (run (handler exc) :: IO a) - in prim (catch# (primBase (run action :: IO a)) handler#) - -catchAll :: - forall a m. MonadUnliftPrim RW m - => m a - -> (forall e . Exception e => e -> m a) - -> m a -catchAll action handler = - withRunInPrimBase $ \run -> - let handler# :: SomeException -> (State# RW -> (# State# RW, a #)) - handler# (SomeException e) = primBase (run (handler e) :: IO a) - in prim (catch# (primBase (run action :: IO a)) handler#) - -catchAllSync :: - forall a m. MonadUnliftPrim RW m - => m a - -> (forall e . Exception e => e -> m a) - -> m a -catchAllSync action handler = - withRunInPrimBase $ \run -> - let handler# :: SomeException -> (State# RW -> (# State# RW, a #)) - handler# exc@(SomeException e) - | isAsyncException exc = raiseIO# exc - | otherwise = primBase (run (handler e) :: IO a) - in prim (catch# (primBase (run action :: IO a)) handler#) - - -maskAsyncExceptions :: forall a m. MonadUnliftPrim RW m => m a -> m a -maskAsyncExceptions action = - withRunInPrimBase $ \run -> prim (maskAsyncExceptions# (primBase (run action :: IO a))) - -unmaskAsyncExceptions :: forall a m. MonadUnliftPrim RW m => m a -> m a -unmaskAsyncExceptions action = - withRunInPrimBase $ \run -> prim (unmaskAsyncExceptions# (primBase (run action :: IO a))) - -maskUninterruptible :: forall a m. MonadUnliftPrim RW m => m a -> m a -maskUninterruptible action = - withRunInPrimBase $ \run -> prim (maskUninterruptible# (primBase (run action :: IO a))) - --- | Same as `GHC.getMaskingState`, but generalized to `MonadPrim` -getMaskingState :: MonadPrim RW m => m MaskingState -getMaskingState = liftPrimBase GHC.getMaskingState - --- | Similar to @throwTo@ from --- [unliftio](https://hackage.haskell.org/package/unliftio/docs/UnliftIO-Exception.html#v:throwTo) --- this will wrap any known non-async exception with `SomeAsyncException`, because --- otherwise semantics of `throwTo` with respect to asynchronous exceptions are violated. -throwTo :: (MonadPrim RW m, Exception e) => GHC.ThreadId -> e -> m () -throwTo tid e = - liftPrimBase $ - GHC.throwTo tid $ - if isAsyncException e - then toException e - else toException $ SomeAsyncException e +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +#if !MIN_VERSION_base(4,9,0) + {-# LANGUAGE ConstraintKinds #-} + {-# LANGUAGE KindSignatures #-} + {-# LANGUAGE ImplicitParams #-} +#endif +-- | +-- Module : Control.Prim.Exception +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Control.Prim.Exception + ( + -- * Throwing + module Control.Prim.Monad.Throw + , throw + , throwTo + , impureThrow + -- * Catching + , catch + , catchAny + , catchAnySync + , catchAll + , catchAllSync + , try + , tryAny + , tryAnySync + , onException + -- TODO: Implement: + -- , onAsyncException + , withException + , withAnyException + -- TODO: Implement: + -- , withAsyncException + , finally + , bracket + , bracket_ + , bracketOnError + , ufinally + , ubracket + , ubracket_ + , ubracketOnError + , mask + , mask_ + , maskPrimBase_ + , uninterruptibleMask + , uninterruptibleMask_ + , uninterruptibleMaskPrimBase_ + , maskAsyncExceptions + , unmaskAsyncExceptions + , maskUninterruptible + , GHC.MaskingState(..) + , getMaskingState + -- * Exceptions + , GHC.Exception(..) + , GHC.SomeException + -- ** Async exceptions + , GHC.AsyncException(..) + , GHC.SomeAsyncException(..) + , isSyncException + , isAsyncException + , GHC.asyncExceptionToException + , GHC.asyncExceptionFromException + -- ** Standard exceptions + , GHC.ErrorCall(..) + , GHC.ArithException(..) + , GHC.ArrayException(..) + , GHC.AssertionFailed(..) + , GHC.IOException + , GHC.NonTermination(..) + , GHC.NestedAtomically(..) + , GHC.BlockedIndefinitelyOnMVar(..) + , GHC.BlockedIndefinitelyOnSTM(..) + , GHC.AllocationLimitExceeded(..) + , GHC.Deadlock(..) + -- * CallStack + , CallStack + , HasCallStack + , callStack + , getCallStack + , prettyCallStack + , SrcLoc(..) + , prettySrcLoc + , module Control.Prim.Monad + ) where + +import qualified Control.Exception as GHC +import Control.Prim.Monad +import Control.Prim.Monad.Throw +import Control.Prim.Monad.Unsafe +import qualified GHC.Conc as GHC +import GHC.Exts +import GHC.Stack +#if !MIN_VERSION_base(4,9,0) +import Data.List (intercalate) +import GHC.SrcLoc +#endif +--import GHC.IO (IO(..)) + + +----- Exceptions + +isSyncException :: GHC.Exception e => e -> Bool +isSyncException = not . isAsyncException +{-# INLINE isSyncException #-} + +isAsyncException :: GHC.Exception e => e -> Bool +isAsyncException exc = + case GHC.fromException (GHC.toException exc) of + Just (GHC.SomeAsyncException _) -> True + Nothing -> False +{-# INLINE isAsyncException #-} + +-- | This is the same as `throwIO`, but works with any `MonadPrim` without restriction on +-- `RealWorld`. +throw :: (GHC.Exception e, MonadPrim s m) => e -> m a +throw e = unsafePrim (raiseIO# (GHC.toException e)) +-- {-# INLINEABLE throw #-} + + +-- | Raise an impure exception from pure code. Returns a thunk, which will result in a +-- supplied exceptionn being thrown when evaluated. +-- +-- @since 0.3.0 +impureThrow :: GHC.Exception e => e -> a +impureThrow e = raise# (GHC.toException e) + + +-- | Similar to `throwTo`, except that it wraps any known non-async exception with +-- `SomeAsyncException`. This is necessary, because receiving thread will get the exception in +-- an asynchronous manner and without proper wrapping it will not be able to distinguish it +-- from a regular synchronous exception +throwTo :: (MonadPrim s m, GHC.Exception e) => GHC.ThreadId -> e -> m () +throwTo tid e = + unsafeIOToPrim $ + GHC.throwTo tid $ + if isAsyncException e + then GHC.toException e + else GHC.toException $ GHC.SomeAsyncException e +-- {-# INLINEABLE throwTo #-} + +-- | Behaves exactly as `catch`, except that it works in any `MonadUnliftPrim`. +catch :: + forall e a m. (GHC.Exception e, MonadUnliftPrim RW m) + => m a + -> (e -> m a) + -> m a +catch action handler = + runInPrimBase2 (const action) handler $ \action# handler# -> + let handler'# :: GHC.SomeException -> (State# RW -> (# State# RW, a #)) + handler'# someExc = + case GHC.fromException someExc of + Just exc -> handler# exc + Nothing -> raiseIO# someExc + in catch# (action# ()) handler'# +-- {-# INLINEABLE catch #-} +--{-# SPECIALIZE catch :: GHC.Exception e => IO a -> (e -> IO a) -> IO a #-} + +catchAny :: + forall a m. MonadUnliftPrim RW m + => m a + -> (GHC.SomeException -> m a) + -> m a +catchAny action handler = + runInPrimBase2 (const action) handler $ \action# handler# -> + catch# (action# ()) handler# +-- {-# INLINEABLE catchAny #-} +--{-# SPECIALIZE catchAny :: IO a -> (GHC.SomeException -> IO a) -> IO a #-} + + +catchAnySync :: + forall a m. MonadUnliftPrim RW m + => m a + -> (GHC.SomeException -> m a) + -> m a +catchAnySync action handler = + catchAny action $ \exc -> + when (isAsyncException exc) (throw exc) >> handler exc +-- {-# INLINEABLE catchAnySync #-} + +catchAll :: + forall a m. MonadUnliftPrim RW m + => m a + -> (forall e . GHC.Exception e => e -> m a) + -> m a +catchAll action handler = + runInPrimBase2 + (const action) + (\(GHC.SomeException e) -> handler e) + (\action# handler# -> catch# (action# ()) handler#) +-- {-# INLINEABLE catchAll #-} + +catchAllSync :: + forall a m. MonadUnliftPrim RW m + => m a + -> (forall e . GHC.Exception e => e -> m a) + -> m a +catchAllSync action handler = + catchAll action $ \exc -> + when (isAsyncException exc) (throw exc) >> handler exc +-- {-# INLINEABLE catchAllSync #-} + + +try :: (GHC.Exception e, MonadUnliftPrim RW m) => m a -> m (Either e a) +try f = catch (fmap Right f) (pure . Left) +-- {-# INLINEABLE try #-} +--{-# SPECIALIZE try :: GHC.Exception e => IO a -> IO (Either e a) #-} + +tryAny :: MonadUnliftPrim RW m => m a -> m (Either GHC.SomeException a) +tryAny f = catchAny (Right <$> f) (pure . Left) +-- {-# INLINEABLE tryAny #-} + +tryAnySync :: MonadUnliftPrim RW m => m a -> m (Either GHC.SomeException a) +tryAnySync f = catchAnySync (Right <$> f) (pure . Left) + + +-- | Run an action, while invoking an exception handler if that action fails for some +-- reason. Exception handling function has async exceptions masked, but it is still +-- interruptible, which can be undesired in some scenarios. If you are sure that the +-- cleanup action does not deadlock and you do need hard guarantees that it gets executed +-- you can run it as uninterruptible: +-- +-- > uninterruptibleMask $ \restore -> withException (restore action) handler +-- +-- @since 0.3.0 +withException :: + (MonadUnliftPrim RW m, GHC.Exception e) => m a -> (e -> m b) -> m a +withException action handler = + mask $ \restore -> do + catch + (restore action) + (\exc -> catchAnySync (void $ handler exc) (\_ -> pure ()) >> throw exc) + + +-- | Same as `withException`, but will invoke exception handling function on all +-- exceptions. +-- +-- @since 0.3.0 +withAnyException :: MonadUnliftPrim RW m => m a -> (GHC.SomeException -> m b) -> m a +withAnyException thing after = + mask $ \restore -> do + catchAny + (restore thing) + (\exc -> catchAnySync (void $ after exc) (\_ -> pure ()) >> throw exc) + +-- | Async safe version of 'EUnsafe.onException'. +-- +-- @since 0.1.0.0 +onException :: MonadUnliftPrim RW m => m a -> m b -> m a +onException thing after = withAnyException thing (const after) + + +-- +-- @since 0.3.0 +bracket :: MonadUnliftPrim RW m => m a -> (a -> m b) -> (a -> m c) -> m c +bracket acquire cleanup action = + mask $ \restore -> do + resource <- acquire + result <- + catchAny (restore (action resource)) $ \exc -> do + catchAnySync (void $ cleanup resource) $ \_ -> pure () + throw exc + result <$ cleanup resource +{-# INLINEABLE bracket #-} + +bracketOnError :: MonadUnliftPrim RW m => m a -> (a -> m b) -> (a -> m c) -> m c +bracketOnError acquire cleanup action = + mask $ \restore -> do + resource <- acquire + catchAny (restore (action resource)) $ \exc -> do + catchAnySync (void $ cleanup resource) $ \_ -> pure () + throw exc + +finally :: MonadUnliftPrim RW m => m a -> m b -> m a +finally action cleanup = + mask $ \restore -> do + result <- + catchAny (restore action) $ \exc -> do + catchAnySync (void cleanup) $ \_ -> pure () + throw exc + result <$ cleanup + + + +-- +-- @since 0.3.0 +bracket_ :: MonadUnliftPrim RW m => m a -> m b -> m c -> m c +bracket_ acquire cleanup action = bracket acquire (const cleanup) (const action) + + +ubracket :: MonadUnliftPrim RW m => m a -> (a -> m b) -> (a -> m c) -> m c +ubracket acquire cleanup action = + uninterruptibleMask $ \restore -> + bracket (restore acquire) cleanup (restore . action) + + +-- +-- @since 0.3.0 +ubracket_ :: MonadUnliftPrim RW m => m a -> m b -> m c -> m c +ubracket_ acquire cleanup action = ubracket acquire (const cleanup) (const action) + + +ubracketOnError :: MonadUnliftPrim RW m => m a -> (a -> m b) -> (a -> m c) -> m c +ubracketOnError acquire cleanup action = + uninterruptibleMask $ \restore -> + bracketOnError (restore acquire) cleanup (restore . action) + +ufinally :: MonadUnliftPrim RW m => m a -> m b -> m a +ufinally action cleanup = + uninterruptibleMask $ \restore -> finally (restore action) cleanup + + +-- | Mask all asychronous exceptions, but keep it interruptible, unless the inherited state +-- was uninterruptible already, in which case this action has no affect. Same as +-- `Control.Exception.mask_`, except that it is polymorphic in state token. Inside a state +-- thread it cannot affect the result of computation, therefore it is safe to use it within +-- `ST` monad. +-- +-- @since 0.3.0 +mask_ :: forall a m s. MonadUnliftPrim s m => m a -> m a +mask_ action = + unsafeIOToPrim getMaskingState >>= \case + GHC.Unmasked -> runInPrimBase action maskAsyncExceptionsInternal# + _ -> action +{-# INLINEABLE mask_ #-} + + +maskPrimBase_ :: forall a n m s. (MonadPrim s m, MonadPrimBase s n) => n a -> m a +maskPrimBase_ action = + unsafeIOToPrim getMaskingState >>= \case + GHC.Unmasked -> prim (maskAsyncExceptionsInternal# (primBase action)) + _ -> liftPrimBase action +{-# INLINEABLE maskPrimBase_ #-} + +-- | Mask all asychronous exceptions, but keep it interruptible, unless the inherited state +-- was uninterruptible already, in which case this action has no affect. Same as +-- `Control.Exception.mask`, except that it is polymorphic in state token. Inside a state +-- thread it cannot affect the result of computation, therefore it is safe to use it within +-- `ST` monad. +-- +-- @since 0.3.0 +mask :: + forall a m s. MonadUnliftPrim s m + => ((forall b. m b -> m b) -> m a) + -> m a +mask action = do + unsafeIOToPrim getMaskingState >>= \case + GHC.Unmasked -> + runInPrimBase + (action (`runInPrimBase` unmaskAsyncExceptionsInternal#)) + maskAsyncExceptionsInternal# + GHC.MaskedInterruptible -> + action (`runInPrimBase` maskAsyncExceptionsInternal#) + GHC.MaskedUninterruptible -> action uninterruptibleMask_ +{-# INLINEABLE mask #-} +--{-# SPECIALIZE mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b #-} + +-- | Mask all asychronous exceptions and mark it uninterruptible. Same as +-- `Control.Exception.uninterruptibleMask`, except that it is polymorphic in state +-- token. Inside a state thread it cannot affect the result of computation, therefore it +-- is safe to use it within `ST` monad. +-- +-- @since 0.3.0 +uninterruptibleMask :: + forall a m s. MonadUnliftPrim s m + => ((forall b. m b -> m b) -> m a) + -> m a +uninterruptibleMask action = do + unsafeIOToPrim getMaskingState >>= \case + GHC.Unmasked -> + runInPrimBase + (action (`runInPrimBase` unmaskAsyncExceptionsInternal#)) + maskAsyncExceptionsInternal# + GHC.MaskedInterruptible -> + action (`runInPrimBase` maskAsyncExceptionsInternal#) + GHC.MaskedUninterruptible -> action uninterruptibleMask_ +{-# INLINEABLE uninterruptibleMask #-} + + +-- | Mask all async exceptions and make sure evaluation cannot be interrupted. It is +-- polymorphic in the state token because it is perfectly safe to use with `ST` actions that +-- don't perform any allocations. It doesn't have to be restricted to `RealWorld` because it +-- has no impact on other threads and can't affect the result of computation, moreover pure +-- functions that implement tight loops are already non-interruptible. In fact using this +-- function is more dangerous in `IO` than it is in `ST`, because misuse can lead to deadlocks +-- in a concurrent setting. +-- +-- @since 0.3.0 +uninterruptibleMask_ :: forall a m s. MonadUnliftPrim s m => m a -> m a +uninterruptibleMask_ action = runInPrimBase action maskUninterruptibleInternal# +{-# INLINEABLE uninterruptibleMask_ #-} + +uninterruptibleMaskPrimBase_ :: forall a n m s. (MonadPrimBase s n, MonadPrim s m) => n a -> m a +uninterruptibleMaskPrimBase_ action = prim (maskUninterruptibleInternal# (primBase action)) +{-# INLINEABLE uninterruptibleMaskPrimBase_ #-} + + +-- | A direct wrapper around `maskAsyncExceptions#` primop. This is different and more +-- dangerous than `mask_` because it can turn uninterrubtable state into interruptable. +maskAsyncExceptions :: forall a m. MonadUnliftPrim RW m => m a -> m a +maskAsyncExceptions action = runInPrimBase action maskAsyncExceptions# +{-# INLINEABLE maskAsyncExceptions #-} + + +-- | A direct wrapper around `unmaskAsyncExceptions#` primop. +unmaskAsyncExceptions :: forall a m. MonadUnliftPrim RW m => m a -> m a +unmaskAsyncExceptions action = runInPrimBase action unmaskAsyncExceptions# +{-# INLINEABLE unmaskAsyncExceptions #-} + + +-- | A direct wrapper around `maskUninterruptible#` primop. +maskUninterruptible :: forall a m. MonadUnliftPrim RW m => m a -> m a +maskUninterruptible action = runInPrimBase action maskUninterruptible# +{-# INLINEABLE maskUninterruptible #-} + +maskAsyncExceptionsInternal# :: (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) +maskAsyncExceptionsInternal# = unsafeCoerce# maskAsyncExceptions# +{-# INLINEABLE maskAsyncExceptionsInternal# #-} + +maskUninterruptibleInternal# :: (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) +maskUninterruptibleInternal# = unsafeCoerce# maskUninterruptible# +{-# INLINEABLE maskUninterruptibleInternal# #-} + +unmaskAsyncExceptionsInternal# :: (State# s -> (# State# s, b #)) -> State# s -> (# State# s, b #) +unmaskAsyncExceptionsInternal# = unsafeCoerce# unmaskAsyncExceptions# +{-# INLINEABLE unmaskAsyncExceptionsInternal# #-} + +-- | Same as `GHC.getMaskingState`, but generalized to `MonadPrim` +-- +-- @since 0.3.0 +getMaskingState :: MonadPrim RW m => m GHC.MaskingState +getMaskingState = liftIO GHC.getMaskingState +{-# INLINEABLE getMaskingState #-} + + +#if !MIN_VERSION_base(4,9,0) + +-- | (Implemented for compatibility with GHC-7.10.2) +type HasCallStack = (?callStack :: CallStack) + +callStack :: HasCallStack => CallStack +callStack = ?callStack + +-- | Pretty print a 'SrcLoc'. (Implemented for compatibility with GHC-7.10.2) +-- +-- @since 3.0.0 +prettySrcLoc :: SrcLoc -> String +prettySrcLoc = showSrcLoc + +-- | Pretty print a 'CallStack'. (Implemented for compatibility with GHC-7.10.2) +-- +-- @since 3.0.0 +prettyCallStack :: CallStack -> String +prettyCallStack = intercalate "\n" . prettyCallStackLines + + +prettyCallStackLines :: CallStack -> [String] +prettyCallStackLines cs = case getCallStack cs of + [] -> [] + stk -> "CallStack (from HasCallStack):" + : map ((" " ++) . prettyCallSite) stk + where + prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc +#endif diff --git a/src/Control/Prim/Monad.hs b/src/Control/Prim/Monad.hs --- a/src/Control/Prim/Monad.hs +++ b/src/Control/Prim/Monad.hs @@ -8,11 +8,13 @@ -- module Control.Prim.Monad ( module Control.Prim.Monad.Internal - , touch - , seqPrim - , withAlivePrimBase - , withAliveUnliftPrim - , showsType + , eval + , evalM + , NFData + , deepeval + , deepevalM + , whenM + , unlessM -- * Re-export , module Control.Monad ) where @@ -20,9 +22,21 @@ import GHC.Exts import Control.Prim.Eval import Control.Prim.Monad.Internal -import Data.Typeable import Control.Monad --- | Helper function that converts a type into a string -showsType :: Typeable t => proxy t -> ShowS -showsType = showsTypeRep . typeRep + + +-- | Similar to `when`, but condional is supplied in a form of monadic action rather than a +-- pure value. +-- +-- @since 0.3.0 +whenM :: Monad m => m Bool -> m () -> m () +whenM m action = m >>= \b -> when b action + + +-- | Similar to `unless`, but condional is supplied in a form of monadic action rather than a +-- pure value. +-- +-- @since 0.3.0 +unlessM :: Monad m => m Bool -> m () -> m () +unlessM m action = m >>= \b -> unless b action diff --git a/src/Control/Prim/Monad/Internal.hs b/src/Control/Prim/Monad/Internal.hs --- a/src/Control/Prim/Monad/Internal.hs +++ b/src/Control/Prim/Monad/Internal.hs @@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -- | @@ -18,22 +20,33 @@ module Control.Prim.Monad.Internal ( RW , RealWorld + , MonadIO , MonadPrim(..) , MonadPrimBase(..) + , MonadUnliftIO , MonadUnliftPrim(..) + , ST + , unIO + , unIO_ + , unST + , unST_ + , runST , prim_ , primBase_ + , withRunInIO + , withRunInPrimBase , runInPrimBase - , liftPrimIO - , liftPrimST + , liftIO + , liftST , liftPrimBase , primBaseToIO , primBaseToST ) where import GHC.Exts -import GHC.IO -import GHC.ST +import GHC.IO hiding (liftIO) +import GHC.ST hiding (liftST) +import Control.Exception (SomeException) import Control.Prim.Monad.Throw import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Cont (ContT) @@ -60,10 +73,44 @@ -- | A shorter synonym for the magical `RealWorld` type RW = RealWorld +type MonadIO m = MonadPrim RW m + +type MonadUnliftIO m = MonadUnliftPrim RW m + +class MonadThrow m => MonadPrim s m | m -> s where + -- | Construct a primitive action + prim :: (State# s -> (# State# s, a #)) -> m a + + +class MonadPrim s m => MonadUnliftPrim s m where + + withRunInST :: ((forall a. m a -> ST s a) -> ST s b) -> m b + + runInPrimBase1 :: + (a -> m b) + -> ( (a -> State# s -> (# State# s, b #)) -> State# s -> (# State# s, c #) ) + -> m c + runInPrimBase1 m f# = runInPrimBase2 (\_ -> pure ()) m (\_ -> f#) + {-# INLINE runInPrimBase1 #-} + + runInPrimBase2 :: + (a -> m b) + -> (c -> m d) + -> ( (a -> State# s -> (# State# s, b #)) + -> (c -> State# s -> (# State# s, d #)) + -> State# s -> (# State# s, e #) ) + -> m e + runInPrimBase2 m1 m2 f# = + withRunInST $ \run -> + ST (f# (\a -> unST (run (m1 a))) (\c -> unST (run (m2 c)))) + {-# INLINE runInPrimBase2 #-} + + class MonadUnliftPrim s m => MonadPrimBase s m where -- | Unwrap a primitive action primBase :: m a -> State# s -> (# State# s, a #) + instance MonadPrimBase RealWorld IO where primBase (IO m) = m {-# INLINE primBase #-} @@ -81,36 +128,65 @@ => m a -> ((State# s -> (# State# s, a #)) -> State# s -> (# State# s, b #)) -> m b -runInPrimBase f g = - withRunInPrimBase (\run -> prim (g (primBase (run f :: ST s a)))) +runInPrimBase f g# = runInPrimBase1 (const f) (\f# -> g# (f# ())) {-# INLINE runInPrimBase #-} -class MonadPrim s m => MonadUnliftPrim s m where - withRunInPrimBase :: MonadPrimBase s n => ((forall a. m a -> n a) -> n b) -> m b + +withRunInIO :: + forall m b. MonadUnliftPrim RW m + => ((forall a. m a -> IO a) -> IO b) + -> m b +withRunInIO f = withRunInST $ \run -> coerce (f (\m -> coerce (run m))) +{-# INLINE withRunInIO #-} + + +withRunInPrimBase :: + (MonadUnliftPrim s m, MonadPrimBase s n) + => ((forall a. m a -> n a) -> n b) + -> m b +withRunInPrimBase inner = + withRunInST $ \run -> liftPrimBase (inner (liftST . run)) +{-# INLINE withRunInPrimBase #-} + + + instance MonadUnliftPrim RealWorld IO where - withRunInPrimBase inner = liftPrimBase (inner liftPrimBase) - {-# INLINE withRunInPrimBase #-} + withRunInST inner = coerce (inner liftPrimBase) + {-# INLINE withRunInST #-} + runInPrimBase1 io f# = IO (f# (\e -> unIO (io e))) + {-# INLINE runInPrimBase1 #-} + runInPrimBase2 io1 io2 f# = IO (f# (\e -> unIO (io1 e)) (\e -> unIO (io2 e))) + {-# INLINE runInPrimBase2 #-} instance MonadUnliftPrim s (ST s) where - withRunInPrimBase inner = liftPrimBase (inner liftPrimBase) - {-# INLINE withRunInPrimBase #-} + withRunInST inner = inner liftPrimBase + {-# INLINE withRunInST #-} + runInPrimBase1 st f# = ST (f# (\e -> unST (st e))) + {-# INLINE runInPrimBase1 #-} + runInPrimBase2 st1 st2 f# = ST (f# (\e -> unST (st1 e)) (\e -> unST (st2 e))) + {-# INLINE runInPrimBase2 #-} instance MonadUnliftPrim s m => MonadUnliftPrim s (IdentityT m) where - withRunInPrimBase inner = - IdentityT $ withRunInPrimBase $ \run -> inner (run . runIdentityT) - {-# INLINE withRunInPrimBase #-} + withRunInST inner = IdentityT $ withRunInST $ \run -> inner (run . runIdentityT) + {-# INLINE withRunInST #-} + runInPrimBase1 im f# = IdentityT $ runInPrimBase1 (runIdentityT . im) f# + {-# INLINE runInPrimBase1 #-} + runInPrimBase2 im1 im2 f# = + IdentityT $ runInPrimBase2 (runIdentityT . im1) (runIdentityT . im2) f# + {-# INLINE runInPrimBase2 #-} instance MonadUnliftPrim s m => MonadUnliftPrim s (ReaderT r m) where - withRunInPrimBase inner = - ReaderT $ \r -> withRunInPrimBase $ \run -> inner (run . flip runReaderT r) - {-# INLINE withRunInPrimBase #-} + withRunInST inner = ReaderT $ \r -> withRunInST $ \run -> inner (run . flip runReaderT r) + {-# INLINE withRunInST #-} + runInPrimBase1 rm f# = + ReaderT $ \r -> runInPrimBase1 (\x -> runReaderT (rm x) r) f# + {-# INLINE runInPrimBase1 #-} + runInPrimBase2 rm1 rm2 f# = + ReaderT $ \r -> runInPrimBase2 (\x -> runReaderT (rm1 x) r) (\x -> runReaderT (rm2 x) r) f# + {-# INLINE runInPrimBase2 #-} -class MonadThrow m => MonadPrim s m | m -> s where - -- | Construct a primitive action - prim :: (State# s -> (# State# s, a #)) -> m a - instance MonadPrim RealWorld IO where prim = IO {-# INLINE prim #-} @@ -124,7 +200,7 @@ prim = lift . prim {-# INLINE prim #-} -instance MonadPrim s m => MonadPrim s (ExceptT e m) where +instance (e ~ SomeException, MonadPrim s m) => MonadPrim s (ExceptT e m) where prim = lift . prim {-# INLINE prim #-} @@ -196,21 +272,24 @@ -- | Lift an `IO` action to `MonadPrim` with the `RealWorld` state token. Type restricted -- synonym for `liftPrimBase` -liftPrimIO :: MonadPrim RW m => IO a -> m a -liftPrimIO m = prim (primBase m) -{-# INLINE liftPrimIO #-} +liftIO :: MonadPrim RW m => IO a -> m a +liftIO (IO m) = prim m +{-# INLINE liftIO #-} -- | Lift an `ST` action to `MonadPrim` with the same state token. Type restricted synonym -- for `liftPrimBase` -liftPrimST :: MonadPrim s m => ST s a -> m a -liftPrimST m = prim (primBase m) -{-# INLINE liftPrimST #-} +liftST :: MonadPrim s m => ST s a -> m a +liftST (ST m) = prim m +{-# INLINE liftST #-} -- | Lift an action from the `MonadPrimBase` to another `MonadPrim` with the same state -- token. liftPrimBase :: (MonadPrimBase s n, MonadPrim s m) => n a -> m a liftPrimBase m = prim (primBase m) -{-# INLINE liftPrimBase #-} +{-# INLINE[0] liftPrimBase #-} +{-# RULES + "liftPrimBase/id" liftPrimBase = id + #-} -- | Restrict a `MonadPrimBase` action that works with `RealWorld` to `IO`. primBaseToIO :: MonadPrimBase RealWorld m => m a -> IO a @@ -221,3 +300,25 @@ primBaseToST :: MonadPrimBase s m => m a -> ST s a primBaseToST = liftPrimBase {-# INLINE primBaseToST #-} + + +-- | Unwrap `ST` +unST :: ST s a -> State# s -> (# State# s, a #) +unST (ST m) = m +{-# INLINE unST #-} + + +-- | Unwrap `ST` that returns unit +unST_ :: ST s () -> State# s -> State# s +unST_ (ST m) s = + case m s of + (# s', () #) -> s' +{-# INLINE unST_ #-} + + +-- | Unwrap `IO` that returns unit +unIO_ :: IO () -> State# RW -> State# RW +unIO_ (IO m) s = + case m s of + (# s', () #) -> s' +{-# INLINE unIO_ #-} diff --git a/src/Control/Prim/Monad/Throw.hs b/src/Control/Prim/Monad/Throw.hs --- a/src/Control/Prim/Monad/Throw.hs +++ b/src/Control/Prim/Monad/Throw.hs @@ -20,9 +20,9 @@ import GHC.Exts import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT) -import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.RWS.Lazy as Lazy (RWST) import Control.Monad.Trans.RWS.Strict as Strict (RWST) @@ -53,17 +53,15 @@ -- -- This is an identical class to -- [MonadThrow](https://hackage.haskell.org/package/exceptions/docs/Control-Monad-Catch.html#t:MonadThrow) --- from @exceptions@ package. The reason why it was copied, instead of a direct depency on --- the aforementioned package is because @MonadCatch@ and @MonadMask@ are not right --- abstractions for exception handling in presence of concurrency. +-- from @exceptions@ package. The reason why it was copied, instead of a direct dependency +-- on the aforementioned package is because @MonadCatch@ and @MonadMask@ are not right +-- abstractions for exception handling in presence of concurrency and also because +-- instances for such transformers as `MaybeT` and `ExceptT` are flawed. class Monad m => MonadThrow m where -- | Throw an exception. Note that this throws when this action is run in -- the monad @m@, not when it is applied. It is a generalization of - -- "Control.Exception"'s 'ControlException.throwIO'. - -- - -- Should satisfy the law: + -- "Control.Prim.Exception"'s 'Control.Prim.Exception.throw'. -- - -- > throwM e >> f = throwM e throwM :: Exception e => e -> m a instance MonadThrow Maybe where @@ -85,14 +83,14 @@ instance MonadThrow m => MonadThrow (ContT r m) where throwM = lift . throwM -instance MonadThrow m => MonadThrow (ExceptT e m) where - throwM = lift . throwM +instance (e ~ SomeException, Monad m) => MonadThrow (ExceptT e m) where + throwM e = ExceptT (pure (Left (toException e))) instance MonadThrow m => MonadThrow (IdentityT m) where throwM = lift . throwM -instance MonadThrow m => MonadThrow (MaybeT m) where - throwM = lift . throwM +instance Monad m => MonadThrow (MaybeT m) where + throwM _ = MaybeT (pure Nothing) instance MonadThrow m => MonadThrow (ReaderT r m) where throwM = lift . throwM diff --git a/src/Control/Prim/Monad/Unsafe.hs b/src/Control/Prim/Monad/Unsafe.hs --- a/src/Control/Prim/Monad/Unsafe.hs +++ b/src/Control/Prim/Monad/Unsafe.hs @@ -12,7 +12,9 @@ -- Portability : non-portable -- module Control.Prim.Monad.Unsafe - ( unsafePrimBase + ( unsafePrim + , unsafePrim_ + , unsafePrimBase , unsafePrimBase_ , unsafePrimBaseToPrim , unsafePrimBaseToIO @@ -38,9 +40,28 @@ import System.IO.Unsafe import Control.Prim.Monad.Internal -import Control.Monad.ST (ST) import GHC.IO import GHC.Exts + +-- | Coerce the state token of prim operation and wrap it into a `MonadPrim` action. +-- +-- === Highly unsafe! +-- +-- @since 0.3.0 +unsafePrim :: MonadPrim s m => (State# s' -> (# State# s', a #)) -> m a +unsafePrim m = prim (unsafeCoerce# m) +{-# INLINE unsafePrim #-} + + +-- | Coerce the state token of prim operation and wrap it into a `MonadPrim` action. +-- +-- === Highly unsafe! +-- +-- @since 0.3.0 +unsafePrim_ :: MonadPrim s m => (State# s' -> State# s') -> m () +unsafePrim_ m = prim_ (unsafeCoerce# m) +{-# INLINE unsafePrim_ #-} + -- | Unwrap any `MonadPrimBase` action while coercing the state token -- diff --git a/src/Data/Prim.hs b/src/Data/Prim.hs --- a/src/Data/Prim.hs +++ b/src/Data/Prim.hs @@ -20,6 +20,9 @@ , MonadPrim , RW , RealWorld + , ST + , runST + , showsType -- * Prim type size , byteCount , byteCountType @@ -28,8 +31,6 @@ , alignment , alignmentType , alignmentProxy - -- * Size - , Size(..) -- * Count , Count(..) , unCountBytes @@ -64,9 +65,11 @@ , ForeignPtr , Typeable , Proxy(..) + , module Data.Coerce + , (#.) + , (.#) , module Data.Semigroup , module Data.Monoid - , module Data.Coerce ) where import Control.DeepSeq @@ -84,9 +87,13 @@ import GHC.Base (quotInt, quotRemInt) import GHC.Exts -newtype Size = Size { unSize :: Int } - deriving (Show, Eq, Ord, Num, Real, Integral, Bounded, Enum) +-- | Helper function that converts a type into a string +-- +-- @since 0.3.0 +showsType :: Typeable t => proxy t -> ShowS +showsType = showsTypeRep . typeRep + -- | Get the size of the data type in bytes. Argument is not evaluated. -- -- >>> import Data.Prim @@ -110,7 +117,7 @@ byteCountType = coerce (I# (sizeOf# (proxy# :: Proxy# e))) {-# INLINE byteCountType #-} --- | Same as `sizeOf`, but argument is a `Proxy` of @a@, instead of the type itself. +-- | Same as `byteCount`, but argument is a `Proxy` of @e@, instead of the type itself. -- -- >>> import Data.Prim -- >>> import Data.Proxy @@ -287,8 +294,8 @@ -- | Cast an offset to count. Useful for dealing with regions. -- -- >>> import Data.Prim --- >>> totalCount = Count 10 :: Count Word --- >>> startOffset = Off 4 :: Off Word +-- >>> let totalCount = Count 10 :: Count Word +-- >>> let startOffset = Off 4 :: Off Word -- >>> totalCount - offToCount startOffset -- Count {unCount = 6} -- @@ -393,3 +400,18 @@ prefetchValue3 :: MonadPrim s m => a -> m () prefetchValue3 a = prim_ (prefetchValue3# a) {-# INLINE prefetchValue3 #-} + + +-- | Coerce result of a function (it is also a hidden function in Data.Functor.Utils) +-- +-- @since 0.3.0 +(#.) :: forall a b c proxy. Coercible b c => proxy b c -> (a -> b) -> (a -> c) +(#.) _px = coerce +{-# INLINE (#.) #-} + +-- | Coerce result of a function. Flipped version of `(#.)` +-- +-- @since 0.3.0 +(.#) :: forall a b c proxy. Coercible b c => (a -> b) -> proxy b c -> (a -> c) +(.#) f _px = coerce f +{-# INLINE (.#) #-} diff --git a/src/Data/Prim/Array.hs b/src/Data/Prim/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Array.hs @@ -0,0 +1,3117 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +-- | +-- Module : Data.Prim.Array +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Array + ( -- $arrays + Size(..) + -- * Boxed Array + -- $boxedArray + + -- ** Immutable + , BArray(..) + , isSameBArray + , sizeOfBArray + , indexBArray + , copyBArray + , cloneBArray + , thawBArray + , thawCopyBArray + , toListBArray + , fromListBArray + , fromListBArrayN + , fromBaseBArray + , toBaseBArray + -- ** Mutable + , BMArray(..) + , getSizeOfBMArray + , readBMArray + , writeBMArray + , writeLazyBMArray + , writeDeepBMArray + , isSameBMArray + , newBMArray + , newLazyBMArray + , newRawBMArray + , makeBMArray + , moveBMArray + , cloneBMArray + , shrinkBMArray + , resizeBMArray + , resizeRawBMArray + , freezeBMArray + , freezeCopyBMArray + + -- * Small Boxed Array + -- ** Immutable + , SBArray(..) + , isSameSBArray + , sizeOfSBArray + , indexSBArray + , copySBArray + , cloneSBArray + , thawSBArray + , thawCopySBArray + , toListSBArray + , fromListSBArray + , fromListSBArrayN + -- ** Mutable + , SBMArray(..) + , isSameSBMArray + , getSizeOfSBMArray + , readSBMArray + , writeSBMArray + , writeLazySBMArray + , writeDeepSBMArray + , newSBMArray + , newLazySBMArray + , newRawSBMArray + , makeSBMArray + , moveSBMArray + , cloneSBMArray + , shrinkSBMArray + , resizeSBMArray + , resizeRawSBMArray + , freezeSBMArray + , freezeCopySBMArray + -- * Unboxed Array + -- ** Immutable + , UArray(..) + , isSameUArray + , isPinnedUArray + , sizeOfUArray + , indexUArray + , copyUArray + , thawUArray + , toListUArray + , fromListUArray + , fromListUArrayN + , fromBaseUArray + , toBaseUArray + -- ** Mutable + , UMArray(..) + , isSameUMArray + , isPinnedUMArray + , getSizeOfUMArray + , readUMArray + , writeUMArray + , newUMArray + , newRawUMArray + , makeUMArray + + , newPinnedUMArray + , newRawPinnedUMArray + , makePinnedUMArray + , newAlignedPinnedUMArray + , newRawAlignedPinnedUMArray + , makeAlignedPinnedUMArray + , moveUMArray + , setUMArray + , shrinkUMArray + , resizeUMArray + , freezeUMArray + -- * Helper functions + , uninitialized + , makeMutWith + , fromListMutWith + , foldrWithFB + , eqWith + , compareWith + , appendWith + , concatWith + ) where + +import Control.DeepSeq +import Control.Prim.Exception +import qualified Data.Foldable as F +import Data.Functor.Classes +import qualified Data.List.NonEmpty as NE (toList) +import Data.Prim +import Data.Prim.Class +import Foreign.Prim +import qualified Data.Array.Base as A +import qualified GHC.Arr as A + +-- $arrays +-- +-- Minimal interface, wrappers around primops +-- +-- Indexing and Size type +-- +-- As in the rest of the library majority of the functions are unsafe. +-- +-- no fusion +-- +-- Boxed vs unboxed concept +-- +-- Mutable vs Immutable +-- +-- Note more features in primal-memory and primal-mutable + + +newtype Size = Size { unSize :: Int } + deriving (Show, Eq, Ord, Num, Real, Integral, Bounded, Enum) + +instance Prim Size where + type PrimBase Size = Int + + +----------------- +-- Boxed Array -- +-- =========== -- + + +-- Immutable Boxed Array -- +--------------------------- + +-- $boxedArray A boxed array is essentially a contiguous chunk of memory that holds +-- pointers to actual elements that are being stored somewhere else on the heap. Therefore +-- it is more efficient to use `UArray` if the element being stored has a `Prim` instance +-- or can have created for it, because this avoids an extra level of indirection. However +-- this is not always possible and for this reason we have boxed arrays. + + +-- | Immutable array with boxed elements. +-- +-- @since 0.3.0 +data BArray e = BArray (Array# e) + +-- | @since 0.3.0 +instance Functor BArray where + fmap f a = + runST $ + makeBMArray + (sizeOfBArray a) + (pure . f . indexBArray a) >>= freezeBMArray + {-# INLINE fmap #-} + (<$) x a = runST $ newLazyBMArray (sizeOfBArray a) x >>= freezeBMArray + {-# INLINE (<$) #-} + +-- | @since 0.3.0 +instance Foldable BArray where + null = (== 0) . sizeOfBArray + {-# INLINE null #-} + length = coerce . sizeOfBArray + {-# INLINE length #-} + foldr = foldrWithFB sizeOfBArray indexBArray + {-# INLINE foldr #-} + +instance Show1 BArray where +#if MIN_VERSION_transformers(0,5,0) + liftShowsPrec _ = liftShowsPrecArray "BArray" +#else + showsPrec1 = liftShowsPrecArray "BArray" showList +#endif + +instance Show e => Show (BArray e) where + showsPrec = showsPrec1 + +instance IsList (BArray e) where + type Item (BArray e) = e + fromList = fromListBArray + {-# INLINE fromList #-} + fromListN n = fromListBArrayN (coerce n) + {-# INLINE fromListN #-} + toList = toListBArray + {-# INLINE toList #-} + +instance e ~ Char => IsString (BArray e) where + fromString = fromListBArray + {-# INLINE fromString #-} + +instance NFData e => NFData (BArray e) where + rnf = foldrWithFB sizeOfBArray indexBArray deepseq () + {-# INLINE rnf #-} + +instance Eq e => Eq (BArray e) where + (==) = eqWith isSameBArray sizeOfBArray indexBArray + {-# INLINE (==) #-} + +instance Ord e => Ord (BArray e) where + compare = compareWith isSameBArray sizeOfBArray indexBArray + {-# INLINE compare #-} + +instance Eq1 BArray where +#if MIN_VERSION_transformers(0,5,0) + liftEq = liftEqWith sizeOfBArray indexBArray + {-# INLINE liftEq #-} +#else + eq1 = liftEqWith sizeOfBArray indexBArray (==) + {-# INLINE eq1 #-} +#endif + + +instance Ord1 BArray where +#if MIN_VERSION_transformers(0,5,0) + liftCompare = liftCompareWith sizeOfBArray indexBArray + {-# INLINE liftCompare #-} +#else + compare1 = liftCompareWith sizeOfBArray indexBArray compare + {-# INLINE compare1 #-} +#endif + + +instance Semigroup (BArray e) where + (<>) = appendWith newRawBMArray copyBArray freezeBMArray sizeOfBArray + {-# INLINE (<>) #-} + sconcat xs = concatWith newRawBMArray copyBArray freezeBMArray sizeOfBArray (NE.toList xs) + {-# INLINE sconcat #-} + stimes n = cycleWith newRawBMArray copyBArray freezeBMArray sizeOfBArray (fromIntegral n) + {-# INLINE stimes #-} + +instance Monoid (BArray e) where + mempty = runST $ newRawBMArray 0 >>= freezeBMArray + {-# NOINLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat = concatWith newRawBMArray copyBArray freezeBMArray sizeOfBArray + {-# INLINE mconcat #-} + +-- | Compare pointers for two immutable arrays and see if they refer to the exact same one. +-- +-- @since 0.3.0 +isSameBArray :: BArray a -> BArray a -> Bool +isSameBArray a1 a2 = runST (isSameBMArray <$> thawBArray a1 <*> thawBArray a2) +{-# INLINE isSameBArray #-} + +-- | /O(1)/ - Get the number of elements in an immutable array +-- +-- Documentation for utilized primop: `sizeofArray#`. +-- +-- @since 0.3.0 +sizeOfBArray :: forall e. BArray e -> Size +sizeOfBArray (BArray a#) = Size (I# (sizeofArray# a#)) +{-# INLINE sizeOfBArray #-} + +-- | /O(1)/ - Index an element in the immutable boxed array. +-- +-- Documentation for utilized primop: `indexArray#`. +-- +-- [Unsafe] Bounds are not checked. When a precondition for @ix@ argument is violated the +-- result is either unpredictable output or failure with a segfault. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim.Array +-- >>> let a = fromListBArray [[0 .. i] | i <- [0 .. 10 :: Int]] +-- >>> indexBArray a 1 +-- [0,1] +-- >>> indexBArray a 5 +-- [0,1,2,3,4,5] +-- +-- @since 0.3.0 +indexBArray :: + forall e. + BArray e + -- ^ /array/ - Array where to lookup an element from + -> Int + -- ^ /ix/ - Position of the element within the @array@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfBArray array) + -> e +indexBArray (BArray a#) (I# i#) = + case indexArray# a# i# of + (# x #) -> x +{-# INLINE indexBArray #-} + + +-- | /O(sz)/ - Make an exact copy of a subsection of a pure immutable array. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also possibility when the @sz is +-- too large. +-- +-- Documentation for utilized primop: `cloneArray#`. +-- +-- ====__Examples__ +-- +-- >>> let a = fromListBArray ['a'..'z'] +-- >>> a +-- BArray "abcdefghijklmnopqrstuvwxyz" +-- >>> cloneBArray a 23 3 +-- BArray "xyz" +-- +-- @since 0.3.0 +cloneBArray :: + forall e. + BArray e + -- ^ /srcArray/ - Immutable source array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned immutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfBArray srcArray) + -- + -- Should be less then the actual available memory + -> BArray e +cloneBArray (BArray a#) (I# i#) (Size (I# n#)) = BArray (cloneArray# a# i# n#) +{-# INLINE cloneBArray #-} + + + +-- | /O(sz)/ - Copy a subsection of an immutable array into a subsection of a mutable +-- array. Source and destination arrays must not be the same array in different states. +-- +-- Documentation for utilized primop: `copyArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or more +-- likely a failure with a segfault. +-- +-- @since 0.3.0 +copyBArray :: + forall e m s. MonadPrim s m + => BArray e + -- ^ /srcArray/ - Source immutable array + -- + -- /__Precondition:__/ + -- + -- > srcMutArray <- thawBArray srcArray + -- > srcMutArray /= dstMutArray + -> Int + -- ^ /srcStartIx/ - Offset into the source immutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcStartIx < unSize (sizeOfBArray srcArray) + -> BMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where the copy should start + -- at + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfBMArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcStartIx + unSize sz < unSize (sizeOfBArray srcArray) + -- + -- > dstSize <- getSizeOfBMArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -> m () +copyBArray (BArray src#) (I# srcOff#) (BMArray dst#) (I# dstOff#) (Size (I# n#)) = + prim_ (copyArray# src# srcOff# dst# dstOff# n#) +{-# INLINE copyBArray #-} + + +-- | /O(1)/ - Convert a pure immutable boxed array into a mutable boxed array. Use +-- `freezeBMArray` in order to go in the opposite direction. +-- +-- Documentation for utilized primop: `unsafeThawArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the mutable boxed array will also be reflected in +-- the source immutable array as well. See `thawCopyBArray` that avoids this problem with +-- a fresh allocation and data copy. +-- +-- ====__Examples__ +-- +-- >>> ma <- thawBArray $ fromListBArray [1 .. 5 :: Integer] +-- >>> writeBMArray ma 1 10 +-- >>> freezeBMArray ma +-- BArray [1,10,3,4,5] +-- +-- Be careful not to retain a reference to the pure immutable source array after the +-- thawed version gets mutated. +-- +-- >>> let a = fromListBArray [1 .. 5 :: Integer] +-- >>> ma' <- thawBArray a +-- >>> writeBMArray ma' 0 100000 +-- >>> a +-- BArray [100000,2,3,4,5] +-- +-- @since 0.3.0 +thawBArray :: + forall e m s. MonadPrim s m + => BArray e + -- ^ /array/ - Source immutable array that will be thawed + -> m (BMArray e s) +thawBArray (BArray a#) = prim $ \s -> + case unsafeThawArray# a# s of + (# s', ma# #) -> (# s', BMArray ma# #) +{-# INLINE thawBArray #-} + +-- TODO: add a test case for the properties +-- > ma' <- thawCopyBArray a i n +-- +-- Is equivalent to: +-- +-- > ma' <- newRawBMArray n >>= \ma -> ma <$ copyBArray a i ma 0 n +-- +-- > thawCopyBArray a i n === thawBArray $ cloneBArray a i n +-- +-- | /O(sz)/ - Create a new mutable array with size @sz@ and copy that number of elements +-- from source immutable @srcArray@ starting at an offset @startIx@ into the newly created +-- @dstMutArray@. This function can help avoid an issue with referential transparency that +-- is inherent to `thawBArray`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also a possibility when the @sz is +-- too large. +-- +-- Documentation for utilized primop: `thawArray#`. +-- +-- ====__Examples__ +-- +-- >>> let a = fromListBArray [1 .. 5 :: Int] +-- >>> ma <- thawCopyBArray a 1 3 +-- >>> writeBMArray ma 1 10 +-- >>> freezeBMArray ma +-- BArray [2,10,4] +-- >>> a +-- BArray [1,2,3,4,5] +-- +-- @since 0.3.0 +thawCopyBArray :: + forall e m s. MonadPrim s m + => BArray e + -- ^ /srcArray/ - Immutable source array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned mutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfBArray srcArray) + -- + -- Should be less then the actual available memory + -> m (BMArray e s) + -- ^ /dstMutArray/ - Newly created destination mutable boxed array +thawCopyBArray (BArray a#) (I# i#) (Size (I# n#)) = prim $ \s -> + case thawArray# a# i# n# s of + (# s', ma# #) -> (# s', BMArray ma# #) +{-# INLINE thawCopyBArray #-} + + + +-- | Convert a pure boxed array into a list. It should work fine with GHC built-in list +-- fusion. +-- +-- @since 0.1.0 +toListBArray :: forall e. BArray e -> [e] +toListBArray ba = build (\ c n -> foldrWithFB sizeOfBArray indexBArray c n ba) +{-# INLINE toListBArray #-} + + + +-- | /O(min(length list, sz))/ - Same as `fromListBArray`, except that it will allocate an +-- array exactly of @n@ size, as such it will not convert any portion of the list that +-- doesn't fit into the newly created array. +-- +-- [Partial] When length of supplied list is in fact smaller then the expected size @sz@, +-- thunks with `UndefinedElement` exception throwing function will be placed in the tail +-- portion of the array. +-- +-- [Unsafe] When a precondition @sz@ is violated this function can result in critical +-- failure with out of memory or `HeapOverflow` async exception. +-- +-- ====__Examples__ +-- +-- >>> fromListBArrayN 3 [1 :: Int, 2, 3] +-- BArray [1,2,3] +-- >>> fromListBArrayN 3 [1 :: Int ..] +-- BArray [1,2,3] +-- +-- @since 0.1.0 +fromListBArrayN :: + forall e. HasCallStack + => Size -- ^ /sz/ - Expected number of elements in the @list@ + -> [e] -- ^ /list/ - A list to bew loaded into the array + -> BArray e +fromListBArrayN sz xs = + runST $ fromListMutWith newRawBMArray writeBMArray sz xs >>= freezeBMArray +{-# INLINE fromListBArrayN #-} + + +-- | /O(length list)/ - Convert a list into an immutable boxed array. It is more efficient to use +-- `fromListBArrayN` when the number of elements is known ahead of time. The reason for this +-- is that it is necessary to iterate the whole list twice: once to count how many elements +-- there is in order to create large enough array that can fit them; and the second time to +-- load the actual elements. Naturally, infinite lists will grind the program to a halt. +-- +-- ====__Example__ +-- +-- >>> fromListBArray "Hello Haskell" +-- BArray "Hello Haskell" +-- +-- @since 0.3.0 +fromListBArray :: forall e. [e] -> BArray e +fromListBArray xs = fromListBArrayN (coerce (length xs)) xs +{-# INLINE fromListBArray #-} + + + +-- | /O(1)/ - cast a boxed immutable `A.Array` that is wired with GHC to `BArray` from primal. +-- +-- >>> import Data.Array.IArray as IA +-- >>> let arr = IA.listArray (10, 15) [30 .. 35] :: IA.Array Int Integer +-- >>> arr +-- array (10,15) [(10,30),(11,31),(12,32),(13,33),(14,34),(15,35)] +-- >>> fromBaseBArray arr +-- BArray [30,31,32,33,34,35] +-- +-- @since 0.3.0 +fromBaseBArray :: A.Array ix e -> BArray e +fromBaseBArray (A.Array _ _ _ a#) = BArray a# + +-- | /O(1)/ - cast a boxed `BArray` from primal into `A.Array`, which is wired with +-- GHC. Resulting array range starts at 0, like any sane array would. +-- +-- >>> let arr = fromListBArray [1, 2, 3 :: Integer] +-- >>> arr +-- BArray [1,2,3] +-- >>> toBaseBArray arr +-- array (0,2) [(0,1),(1,2),(2,3)] +-- +-- @since 0.3.0 +toBaseBArray :: BArray e -> A.Array Int e +toBaseBArray a@(BArray a#) = + let Size n = sizeOfBArray a + in A.Array 0 (max 0 (n - 1)) n a# + + +-- Mutable Boxed Array -- +------------------------- + + +-- | Mutable array with boxed elements. +-- +-- @since 0.3.0 +data BMArray e s = BMArray (MutableArray# s e) + +-- | Check if both of the arrays refer to the exact same one. None of the elements are +-- evaluated. +instance Eq (BMArray e s) where + (==) = isSameBMArray + {-# INLINE (==) #-} + + +-- | Compare pointers for two mutable arrays and see if they refer to the exact same one. +-- +-- Documentation for utilized primop: `sameMutableArray#`. +-- +-- @since 0.3.0 +isSameBMArray :: forall a s. BMArray a s -> BMArray a s -> Bool +isSameBMArray (BMArray ma1#) (BMArray ma2#) = + isTrue# (sameMutableArray# ma1# ma2#) +{-# INLINE isSameBMArray #-} + +-- | /O(1)/ - Get the size of a mutable boxed array +-- +-- Documentation for utilized primop: `sizeofMutableArray#`. +-- +-- ====__Example__ +-- +-- >>> ma <- newBMArray 1024 "Element of each cell" +-- >>> getSizeOfBMArray ma +-- Size {unSize = 1024} +-- +-- @since 0.3.0 +getSizeOfBMArray :: + forall e m s. MonadPrim s m + => BMArray e s + -> m Size +getSizeOfBMArray (BMArray ma#) = --pure $! Size (I# (sizeofMutableArray# ma#)) + prim $ \s -> + case getSizeofMutableArray# ma# s of + (# s', n# #) -> (# s', coerce (I# n#) #) +{-# INLINE getSizeOfBMArray #-} + +-- | /O(1)/ - Read an element from a mutable boxed array at the supplied index. +-- +-- Documentation for utilized primop: `readArray#`. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in undefined behavior or a failure +-- with a segfault +-- +-- ==== __Example__ +-- +-- >>> ma <- makeBMArray 10 (pure . ("Element ix: " ++) . show) +-- >>> readBMArray ma 5 +-- "Element ix: 5" +-- +-- @since 0.1.0 +readBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /srcMutArray/ - Array to read an element from + -> Int + -- ^ /ix/ - Index that refers to an element we need within the the @srcMutArray@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfMBArray srcMutArray) + -> m e +readBMArray (BMArray ma#) (I# i#) = prim (readArray# ma# i#) +{-# INLINE readBMArray #-} + + + +-- | /O(1)/ - Write an element @elt@ into the mutable boxed array @dstMutArray@ at the +-- supplied index @ix@. The actual element will be evaluated to WHNF prior to mutation. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in heap corruption or a failure +-- with a segfault +-- +-- ==== __Examples__ +-- +-- >>> ma <- newBMArray 4 (Nothing :: Maybe Integer) +-- >>> writeBMArray ma 2 (Just 2) +-- >>> freezeBMArray ma +-- BArray [Nothing,Nothing,Just 2,Nothing] +-- +-- It is important to note that an element is evaluated prior to being written into a +-- cell, so it will not overwrite the value of an array's cell if it evaluates to an +-- exception: +-- +-- >>> import Control.Prim.Exception +-- >>> writeBMArray ma 2 (impureThrow DivideByZero) +-- *** Exception: divide by zero +-- >>> freezeBMArray ma +-- BArray [Nothing,Nothing,Just 2,Nothing] +-- +-- However, it is evaluated only to Weak Head Normal Form (WHNF), so it is still possible +-- to write something that eventually evaluates to bottom. +-- +-- >>> writeBMArray ma 3 (Just (7 `div` 0 )) +-- >>> freezeBMArray ma +-- BArray [Nothing,Nothing,Just 2,Just *** Exception: divide by zero +-- >>> readBMArray ma 3 +-- Just *** Exception: divide by zero +-- +-- Either `deepseq` or `writeDeepBMArray` can be used to alleviate that. +-- +-- @since 0.3.0 +writeBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /dstMutArray/ - An array to have the element written to + -> Int + -- ^ /ix/ - Index within the the @dstMutArray@ that a refernce to the supplied element + -- @elt@ will be written to. + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfMBArray srcArray) + -> e + -- ^ /elt/ - Element to be written into @dstMutArray@ + -> m () +writeBMArray ma i !x = writeLazyBMArray ma i x -- TODO: figure out why doctests fail sporadically +--writeBMArray ma i = eval >=> writeLazyBMArray ma i +{-# INLINE writeBMArray #-} + +{- +src/Data/Prim/Array.hs:697: failure in expression `freezeBMArray ma' +expected: BArray [Nothing,Nothing,Just 2,Just *** Exception: divide by zero + but got: BArray [Nothing,Nothing,Just 2,Just 5282521669542503534] + ^ +Examples: 180 Tried: 63 Errors: 0 Failures: 1doctests: user error (Language.Haskell.GhciWrapper.close: Interpreter exited with an error (ExitFailure (-6))) +primal> Test suite doctests failed +Test suite failure for package primal-0.3.0.0 + doctests: exited with: ExitFailure 1 +Logs printed to console + + +Examples: 180 Tried: 26 Errors: 0 Failures: 0doctests: user error (Language.Haskell.GhciWrapper.close: Interpreter exited with an error (ExitFailure (-11))) +primal> Test suite doctests failed +Test suite failure for package primal-0.3.0.0 + doctests: exited with: ExitFailure 1 + +https://travis-ci.com/github/lehins/primal/jobs/407895714 +[34/180] src/Data/Prim/Array.hs:699: failure in expression `readBMArray ma 3' +expected: Just *** Exception: divide by zero + but got: Just 140663761379224 + ^ +-} + +-- | /O(1)/ - Same as `writeBMArray` but allows to write a thunk into an array instead of an +-- evaluated element. Careful with memory leaks and thunks that evaluate to exceptions. +-- +-- Documentation for utilized primop: `writeArray#`. +-- +-- [Unsafe] Same reasons as `writeBMArray` +-- +-- @since 0.3.0 +writeLazyBMArray :: + forall e m s. MonadPrim s m + => BMArray e s + -> Int + -> e + -> m () +writeLazyBMArray (BMArray ma#) (I# i#) a = prim_ (writeArray# ma# i# a) +{-# INLINE writeLazyBMArray #-} + + +-- | /O(1)/ - Same as `writeBMArray`, except it ensures that the value being written is +-- fully evaluated, i.e. to Normal Form (NF). +-- +-- [Unsafe] Same reasons as `writeBMArray` +-- +-- @since 0.3.0 +writeDeepBMArray :: + forall e m s. (MonadPrim s m, NFData e) + => BMArray e s + -> Int + -> e + -> m () +writeDeepBMArray ma i !x = + case rnf x of + () -> writeLazyBMArray ma i x +{-# INLINE writeDeepBMArray #-} + + + +-- | Create a mutable boxed array where each element is set to the supplied initial value +-- @elt@, which is evaluated before array allocation happens. See `newLazyBMArray` for +-- an ability to initialize with a thunk. +-- +-- [Unsafe size] Violation of precondition for the @sz@ argument can result in the current +-- thread being killed with `HeapOverflow` asynchronous exception or death of the whole +-- process with some unchecked exception from RTS. +-- +-- ====__Examples__ +-- +-- >>> newBMArray 10 'A' >>= freezeBMArray +-- BArray "AAAAAAAAAA" +-- +-- @since 0.3.0 +newBMArray :: + forall e m s. MonadPrim s m + => Size + -- ^ /sz/ - Size of the array + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> e -- ^ /elt/ - Value to use for all array cells + -> m (BMArray e s) +newBMArray sz x = x `seq` newLazyBMArray sz x +{-# INLINE newBMArray #-} + +-- | Same as `newBMArray`, except initial element is allowed to be a thunk. +-- +-- Documentation for utilized primop: `newArray#`. +-- +-- [Unsafe] Same reasons as `newBMArray` +-- +-- @since 0.3.0 +newLazyBMArray :: + forall e m s. MonadPrim s m + => Size + -> e + -> m (BMArray e s) +newLazyBMArray (Size (I# n#)) a = + prim $ \s -> + case newArray# n# a s of + (# s', ma# #) -> (# s', BMArray ma# #) +{-# INLINE newLazyBMArray #-} + + + + +-- | Create new mutable array, where each element is initilized to a thunk that throws an +-- error when evaluated. This is useful when there is a plan to later iterate over the whole +-- array and write values into each cell in some index aware fashion. Consider `makeBMArray` +-- as an alternative. +-- +-- [Partial] All array cells are initialized with thunks that throw `UndefinedElement` +-- exception when evaluated +-- +-- [Unsafe] Same reasons as `newBMArray` +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim +-- >>> let xs = "Hello Haskell" +-- >>> ma <- newRawBMArray (Size (length xs)) :: IO (BMArray Char RW) +-- >>> mapM_ (\(i, x) -> writeBMArray ma i x) (zip [0..] xs) +-- >>> freezeBMArray ma +-- BArray "Hello Haskell" +-- +-- @since 0.3.0 +newRawBMArray :: + forall e m s. (HasCallStack, MonadPrim s m) + => Size + -> m (BMArray e s) +newRawBMArray sz = newLazyBMArray sz (uninitialized "Data.Prim.Aray" "newRawBMArray") +{-# INLINE newRawBMArray #-} + + + +-- | Create new mutable boxed array of the supplied size and fill it with a monadic action +-- that is applied to indices of each array cell. +-- +-- [Unsafe] Same reasons as `newBMArray` +-- +-- ====__Examples__ +-- +-- >>> ma <- makeBMArray 5 $ \i -> (toEnum (i + 97) :: Char) <$ putStrLn ("Handling index: " ++ show i) +-- Handling index: 0 +-- Handling index: 1 +-- Handling index: 2 +-- Handling index: 3 +-- Handling index: 4 +-- >>> freezeBMArray ma +-- BArray "abcde" +-- +-- @since 0.3.0 +makeBMArray :: + forall e m s. MonadPrim s m + => Size + -> (Int -> m e) + -> m (BMArray e s) +makeBMArray = makeMutWith newRawBMArray writeBMArray +{-# INLINE makeBMArray #-} + + +-- | /O(1)/ - Convert a mutable boxed array into an immutable one. Use `thawBArray` in order +-- to go in the opposite direction. +-- +-- Documentation for utilized primop: `unsafeFreezeArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the source mutable boxed array will also be reflected +-- in the resulting immutable array. See `freezeCopyBMArray` that avoids this problem with +-- fresh allocation. +-- +-- @since 0.3.0 +freezeBMArray :: + forall e m s. MonadPrim s m + => BMArray e s + -> m (BArray e) +freezeBMArray (BMArray ma#) = prim $ \s -> + case unsafeFreezeArray# ma# s of + (# s', a# #) -> (# s', BArray a# #) +{-# INLINE freezeBMArray #-} + + + +-- | /O(sz)/ - Similar to `freezeBMArray`, except it creates a new array with the copy of a +-- subsection of a mutable array before converting it into an immutable. +-- +-- Documentation for utilized primop: `freezeArray#`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault or out of memory exception. +-- +-- @since 0.3.0 +freezeCopyBMArray :: + forall e m s. MonadPrim s m + => BMArray e s + -- ^ /srcArray/ - Source mutable array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned immutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfBArray srcArray) + -- + -- Should be less then actual available memory + -> m (BArray e) +freezeCopyBMArray (BMArray ma#) (I# i#) (Size (I# n#)) = prim $ \s -> + case freezeArray# ma# i# n# s of + (# s', a# #) -> (# s', BArray a# #) +{-# INLINE freezeCopyBMArray #-} + +-- TODO: +-- prop> cloneBMArray ma i n === freezeCopyBMArray ma i n >>= thawBArray +-- prop> cloneBMArray ma i n === newBMArray n undefined >>= \mb -> mb <$ moveBMArray ma i mb 0 n +-- | /O(sz)/ - Allocate a new mutable array of size @sz@ and copy that number of the +-- elements over from the @srcArray@ starting at index @ix@. Similar to `cloneBArray`, +-- except it works on mutable arrays. +-- +-- Documentation for utilized primop: `cloneMutableArray#`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also a possibility when the @sz is +-- too large. +-- +-- @since 0.3.0 +cloneBMArray :: + forall e m s. MonadPrim s m + => BMArray e s + -- ^ /srcArray/ - Source mutable array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned mutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfBArray srcArray) + -- + -- Should be less then actual available memory + -> m (BMArray e s) +cloneBMArray (BMArray ma#) (I# i#) (Size (I# n#)) = + prim $ \s -> + case cloneMutableArray# ma# i# n# s of + (# s', ma'# #) -> (# s', BMArray ma'# #) +{-# INLINE cloneBMArray #-} + + + +-- | /O(1)/ - Reduce the size of a mutable boxed array. +-- +-- Documentation for utilized primop: `shrinkMutableArray#`. +-- +-- [Unsafe] - Violation of preconditions for @sz@ leads to undefined behavior +-- +-- 0.3.0 +shrinkBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /mutArray/ - Mutable unboxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > curSize <- getSizeOfBMArray mutArray + -- > sz <= curSize + -> m () +shrinkBMArray (BMArray ma#) (Size (I# sz#)) = + prim_ (shrinkMutableArray# ma# sz#) +{-# INLINE shrinkBMArray #-} + + +-- | /O(1)/ - Either grow or shrink the size of a mutable unboxed array. Shrinking happens +-- in-place without new array creation and data copy, while growing the array is +-- implemented with creating new array and copy of the data over from the source array +-- @srcMutArray@. This has a consequence that produced array @dstMutArray@ might refer to +-- the same @srcMutArray@ or to a totally new array, which can be checked with +-- `isSameBMArray`. +-- +-- Documentation on the utilized primop: `resizeMutableArray#`. +-- +-- [Unsafe] - Same reasons as in `newRawBMArray`. +-- +-- 0.3.0 +resizeBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /srcMutArray/ - Mutable boxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> e + -- ^ /elt/ - Element to write into extra space at the end when growing the array. + -> m (BMArray e s) -- ^ /dstMutArray/ - produces a resized version of /srcMutArray/. +resizeBMArray (BMArray ma#) (Size (I# sz#)) e = + prim $ \s -> + case resizeMutableArray# ma# sz# e s of + (# s', ma'# #) -> (# s', BMArray ma'# #) +{-# INLINE resizeBMArray #-} + +-- | /O(1)/ - Same as `resizeBMArray`, except when growing the array empty space at the +-- end is filled with bottom. +-- +-- [Partial] - When size @sz@ is larger then the size of @srcMutArray@ then @dstMutArray@ +-- will have cells at the end initialized with thunks that throw `UndefinedElement` +-- exception. +-- +-- [Unsafe] - Same reasons as in `newBMArray`. +-- +-- 0.3.0 +resizeRawBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /srcMutArray/ - Mutable boxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> m (BMArray e s) -- ^ /dstMutArray/ - produces a resized version of /srcMutArray/. +resizeRawBMArray ma sz = resizeBMArray ma sz (uninitialized "Data.Prim.Aray" "resizeRawBMArray") +{-# INLINE resizeRawBMArray #-} + + +-- | /O(sz)/ - Copy a subsection of a mutable array into a subsection of another or the same +-- mutable array. Therefore, unlike `copyBArray`, memory ia allowed to overlap between source +-- and destination. +-- +-- Documentation for utilized primop: `copyMutableArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or more +-- likely a failure with a segfault. +-- +-- @since 0.3.0 +moveBMArray :: + forall e m s. MonadPrim s m + => BMArray e s -- ^ /srcMutArray/ - Source mutable array + -> Int + -- ^ /srcStartIx/ - Offset into the source mutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcSize <- getSizeOfBMArray srcMutArray + -- > srcStartIx < unSize srcSize + -> BMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where copy should start to + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfBMArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcSize <- getSizeOfBMArray srcMutArray + -- > srcStartIx + unSize sz < unSize srcSize + -- + -- > dstSize <- getSizeOfBMArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -- + -> m () +moveBMArray (BMArray src#) (I# srcOff#) (BMArray dst#) (I# dstOff#) (Size (I# n#)) = + prim_ (copyMutableArray# src# srcOff# dst# dstOff# n#) +{-# INLINE moveBMArray #-} + + +----------------------- +-- Small Boxed Array -- +-- ================= -- + + +-- Immutable Small Boxed Array -- +--------------------------------- + +-- | Small boxed immutable array +data SBArray e = SBArray (SmallArray# e) + + +-- | @since 0.3.0 +instance Functor SBArray where + fmap f a = + runST $ + makeSBMArray + (sizeOfSBArray a) + (pure . f . indexSBArray a) >>= freezeSBMArray + {-# INLINE fmap #-} + (<$) x a = runST $ newLazySBMArray (sizeOfSBArray a) x >>= freezeSBMArray + {-# INLINE (<$) #-} + +-- | @since 0.3.0 +instance Foldable SBArray where + null = (== 0) . sizeOfSBArray + {-# INLINE null #-} + length = coerce . sizeOfSBArray + {-# INLINE length #-} + foldr = foldrWithFB sizeOfSBArray indexSBArray + {-# INLINE foldr #-} + +instance Show1 SBArray where +#if MIN_VERSION_transformers(0,5,0) + liftShowsPrec _ = liftShowsPrecArray "SBArray" +#else + showsPrec1 = liftShowsPrecArray "SBArray" showList +#endif + +instance Show e => Show (SBArray e) where + showsPrec = showsPrec1 + +instance IsList (SBArray e) where + type Item (SBArray e) = e + fromList = fromListSBArray + {-# INLINE fromList #-} + fromListN n = fromListSBArrayN (coerce n) + {-# INLINE fromListN #-} + toList = toListSBArray + {-# INLINE toList #-} + +instance e ~ Char => IsString (SBArray e) where + fromString = fromListSBArray + {-# INLINE fromString #-} + +instance NFData e => NFData (SBArray e) where + rnf = foldrWithFB sizeOfSBArray indexSBArray deepseq () + {-# INLINE rnf #-} + + +instance Eq e => Eq (SBArray e) where + (==) = eqWith isSameSBArray sizeOfSBArray indexSBArray + {-# INLINE (==) #-} + +instance Ord e => Ord (SBArray e) where + compare = compareWith isSameSBArray sizeOfSBArray indexSBArray + {-# INLINE compare #-} + +instance Eq1 SBArray where +#if MIN_VERSION_transformers(0,5,0) + liftEq = liftEqWith sizeOfSBArray indexSBArray + {-# INLINE liftEq #-} +#else + eq1 = liftEqWith sizeOfSBArray indexSBArray (==) + {-# INLINE eq1 #-} +#endif + +instance Ord1 SBArray where +#if MIN_VERSION_transformers(0,5,0) + liftCompare = liftCompareWith sizeOfSBArray indexSBArray + {-# INLINE liftCompare #-} +#else + compare1 = liftCompareWith sizeOfSBArray indexSBArray compare + {-# INLINE compare1 #-} +#endif + + +instance Semigroup (SBArray e) where + (<>) = appendWith newRawSBMArray copySBArray freezeSBMArray sizeOfSBArray + {-# INLINE (<>) #-} + sconcat xs = concatWith newRawSBMArray copySBArray freezeSBMArray sizeOfSBArray (NE.toList xs) + {-# INLINE sconcat #-} + stimes n = cycleWith newRawSBMArray copySBArray freezeSBMArray sizeOfSBArray (fromIntegral n) + {-# INLINE stimes #-} + +instance Monoid (SBArray e) where + mempty = runST $ newRawSBMArray 0 >>= freezeSBMArray + {-# NOINLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat = concatWith newRawSBMArray copySBArray freezeSBMArray sizeOfSBArray + {-# INLINE mconcat #-} + + +-- | Compare pointers for two immutable arrays and see if they refer to the exact same one. +-- +-- @since 0.3.0 +isSameSBArray :: SBArray a -> SBArray a -> Bool +isSameSBArray a1 a2 = runST (isSameSBMArray <$> thawSBArray a1 <*> thawSBArray a2) +{-# INLINE isSameSBArray #-} + +-- | /O(1)/ - Get the number of elements in an immutable array +-- +-- Documentation for utilized primop: `sizeofSmallArray#`. +-- +-- @since 0.3.0 +sizeOfSBArray :: forall e. SBArray e -> Size +sizeOfSBArray (SBArray a#) = Size (I# (sizeofSmallArray# a#)) +{-# INLINE sizeOfSBArray #-} + + +-- | /O(1)/ - Index an element in the immutable small boxed array. +-- +-- Documentation for utilized primop: `indexSmallArray#`. +-- +-- [Unsafe] Bounds are not checked. When a precondition for @ix@ argument is violated the +-- result is either unpredictable output or failure with a segfault. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim.Array +-- >>> let a = fromListSBArray [[0 .. i] | i <- [0 .. 10 :: Int]] +-- >>> indexSBArray a 1 +-- [0,1] +-- >>> indexSBArray a 5 +-- [0,1,2,3,4,5] +-- +-- @since 0.3.0 +indexSBArray :: + forall e. + SBArray e + -- ^ /array/ - Array where to lookup an element from + -> Int + -- ^ /ix/ - Position of the element within the @array@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfSBArray array) + -> e +indexSBArray (SBArray a#) (I# i#) = + case indexSmallArray# a# i# of + (# x #) -> x +{-# INLINE indexSBArray #-} + + + +-- | /O(sz)/ - Make an exact copy of a subsection of a pure immutable array. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also a possibility when the @sz is +-- too large. +-- +-- Documentation for utilized primop: `cloneSmallArray#`. +-- +-- ====__Examples__ +-- +-- >>> let a = fromListSBArray ['a'..'z'] +-- >>> a +-- SBArray "abcdefghijklmnopqrstuvwxyz" +-- >>> cloneSBArray a 23 3 +-- SBArray "xyz" +-- +-- @since 0.3.0 +cloneSBArray :: + forall e. + SBArray e + -- ^ /srcArray/ - Immutable source array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfSBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned immutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfSBArray srcArray) + -- + -- Should be less then the actual available memory + -> SBArray e +cloneSBArray (SBArray a#) (I# i#) (Size (I# n#)) = SBArray (cloneSmallArray# a# i# n#) +{-# INLINE cloneSBArray #-} + + + +-- | /O(1)/ - Reduce the size of a mutable small boxed array. +-- +-- Documentation for utilized primop: `shrinkSmallMutableArray#`. +-- +-- [Unsafe] - Violation of preconditions for @sz@ leads to undefined behavior +-- +-- 0.3.0 +shrinkSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /mutArray/ - Mutable unboxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > curSize <- getSizeOfSBMArray mutArray + -- > sz <= curSize + -> m () +shrinkSBMArray (SBMArray ma#) (Size (I# sz#)) = + prim_ (shrinkSmallMutableArray# ma# sz#) +{-# INLINE shrinkSBMArray #-} + + +-- | /O(1)/ - Either grow or shrink the size of a mutable unboxed array. Shrinking happens +-- in-place without new array creation and data copy, while growing the array is +-- implemented with creating new array and copy of the data over from the source array +-- @srcMutArray@. This has a consequence that produced array @dstMutArray@ might refer to +-- the same @srcMutArray@ or to a totally new array, which can be checked with +-- `isSameSBMArray`. +-- +-- Documentation on the utilized primop: `resizeSmallMutableArray#`. +-- +-- [Unsafe] - Same reasons as in `newRawSBMArray`. +-- +-- 0.3.0 +resizeSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /srcMutArray/ - Mutable boxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> e + -- ^ /elt/ - Element to write into extra space at the end when growing the array. + -> m (SBMArray e s) -- ^ /dstMutArray/ - produces a resized version of /srcMutArray/. +resizeSBMArray (SBMArray ma#) (Size (I# sz#)) e = + prim $ \s -> + case resizeSmallMutableArray# ma# sz# e s of + (# s', ma'# #) -> (# s', SBMArray ma'# #) +{-# INLINE resizeSBMArray #-} + +-- | /O(1)/ - Same as `resizeSBMArray`, except when growing the array empty space at the +-- end is filled with bottom. +-- +-- [Partial] - When size @sz@ is larger then the size of @srcMutArray@ then @dstMutArray@ +-- will have cells at the end initialized with thunks that throw `UndefinedElement` +-- exception. +-- +-- [Unsafe] - Same reasons as in `newSBMArray`. +-- +-- 0.3.0 +resizeRawSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /srcMutArray/ - Mutable boxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> m (SBMArray e s) -- ^ /dstMutArray/ - produces a resized version of /srcMutArray/. +resizeRawSBMArray ma sz = resizeSBMArray ma sz (uninitialized "Data.Prim.Aray" "resizeRawSBMArray") +{-# INLINE resizeRawSBMArray #-} + + +-- | /O(sz)/ - Copy a subsection of an immutable array into a subsection of a mutable +-- array. Source and destination arrays must not be the same array in different states. +-- +-- Documentation for utilized primop: `copySmallArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or more +-- likely a failure with a segfault. +-- +-- @since 0.3.0 +copySBArray :: + forall e m s. MonadPrim s m + => SBArray e + -- ^ /srcArray/ - Source immutable array + -- + -- /__Precondition:__/ + -- + -- > srcMutArray <- thawSBArray srcArray + -- > srcMutArray /= dstMutArray + -> Int + -- ^ /srcStartIx/ - Offset into the source immutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcStartIx < unSize (sizeOfSBArray srcArray) + -> SBMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where the copy should start + -- at + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfSBMArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcStartIx + unSize sz < unSize (sizeOfSBArray srcArray) + -- + -- > dstSize <- getSizeOfSBMArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -> m () +copySBArray (SBArray src#) (I# srcOff#) (SBMArray dst#) (I# dstOff#) (Size (I# n#)) = + prim_ (copySmallArray# src# srcOff# dst# dstOff# n#) +{-# INLINE copySBArray #-} + + +-- | /O(1)/ - Convert a pure immutable boxed array into a mutable boxed array. Use +-- `freezeSBMArray` in order to go in the opposite direction. +-- +-- Documentation for utilized primop: `unsafeThawSmallArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the mutable boxed array will also be reflected in +-- the source immutable array as well. See `thawCopySBArray` that avoids this problem with +-- a fresh allocation and data copy. +-- +-- ====__Examples__ +-- +-- >>> ma <- thawSBArray $ fromListSBArray [1 .. 5 :: Integer] +-- >>> writeSBMArray ma 1 10 +-- >>> freezeSBMArray ma +-- SBArray [1,10,3,4,5] +-- +-- Be careful not to retain a reference to the pure immutable source array after the +-- thawed version gets mutated. +-- +-- >>> let a = fromListSBArray [1 .. 5 :: Integer] +-- >>> ma' <- thawSBArray a +-- >>> writeSBMArray ma' 0 100000 +-- >>> a +-- SBArray [100000,2,3,4,5] +-- +-- @since 0.3.0 +thawSBArray :: + forall e m s. MonadPrim s m + => SBArray e + -- ^ /array/ - Source immutable array that will be thawed + -> m (SBMArray e s) +thawSBArray (SBArray a#) = prim $ \s -> + case unsafeThawSmallArray# a# s of + (# s', ma# #) -> (# s', SBMArray ma# #) +{-# INLINE thawSBArray #-} + + +-- | /O(sz)/ - Create a new mutable array with size @sz@ and copy that number of elements +-- from source immutable @srcArray@ starting at an offset @startIx@ into the newly created +-- @dstMutArray@. This function can help avoid an issue with referential transparency that +-- is inherent to `thawSBArray`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also a possibility when the @sz is +-- too large. +-- +-- Documentation for utilized primop: `thawSmallArray#`. +-- +-- ====__Examples__ +-- +-- >>> let a = fromListSBArray [1 .. 5 :: Int] +-- >>> ma <- thawCopySBArray a 1 3 +-- >>> writeSBMArray ma 1 10 +-- >>> freezeSBMArray ma +-- SBArray [2,10,4] +-- >>> a +-- SBArray [1,2,3,4,5] +-- +-- @since 0.3.0 +thawCopySBArray :: + forall e m s. MonadPrim s m + => SBArray e + -- ^ /srcArray/ - Immutable source array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfSBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned mutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfSBArray srcArray) + -- + -- Should be less then the actual available memory + -> m (SBMArray e s) + -- ^ /dstMutArray/ - Newly created destination mutable boxed array +thawCopySBArray (SBArray a#) (I# i#) (Size (I# n#)) = prim $ \s -> + case thawSmallArray# a# i# n# s of + (# s', ma# #) -> (# s', SBMArray ma# #) +{-# INLINE thawCopySBArray #-} + + + +-- | Convert a pure boxed array into a list. It should work fine with GHC built-in list +-- fusion. +-- +-- @since 0.1.0 +toListSBArray :: forall e. SBArray e -> [e] +toListSBArray ba = build (\ c n -> foldrWithFB sizeOfSBArray indexSBArray c n ba) +{-# INLINE toListSBArray #-} + + + +-- | /O(min(length list, sz))/ - Same as `fromListSBArray`, except that it will allocate +-- an array exactly of @n@ size, as such it will not convert any portion of the list that +-- doesn't fit into the newly created array. +-- +-- [Partial] When length of supplied list is in fact smaller then the expected size @sz@, +-- thunks with `UndefinedElement` exception throwing function will be placed in the tail +-- portion of the array. +-- +-- [Unsafe] When a precondition @sz@ is violated this function can result in critical +-- failure with out of memory or `HeapOverflow` async exception. +-- +-- ====__Examples__ +-- +-- >>> fromListSBArrayN 3 [1 :: Int, 2, 3] +-- SBArray [1,2,3] +-- >>> fromListSBArrayN 3 [1 :: Int ..] +-- SBArray [1,2,3] +-- +-- @since 0.1.0 +fromListSBArrayN :: + forall e. HasCallStack + => Size -- ^ /sz/ - Expected number of elements in the @list@ + -> [e] -- ^ /list/ - A list to bew loaded into the array + -> SBArray e +fromListSBArrayN sz xs = + runST $ fromListMutWith newRawSBMArray writeSBMArray sz xs >>= freezeSBMArray +{-# INLINE fromListSBArrayN #-} + + +-- | /O(length list)/ - Convert a list into an immutable boxed array. It is more efficient to use +-- `fromListSBArrayN` when the number of elements is known ahead of time. The reason for this +-- is that it is necessary to iterate the whole list twice: once to count how many elements +-- there is in order to create large enough array that can fit them; and the second time to +-- load the actual elements. Naturally, infinite lists will grind the program to a halt. +-- +-- ====__Example__ +-- +-- >>> fromListSBArray "Hello Haskell" +-- SBArray "Hello Haskell" +-- +-- @since 0.3.0 +fromListSBArray :: forall e. [e] -> SBArray e +fromListSBArray xs = fromListSBArrayN (coerce (length xs)) xs +{-# INLINE fromListSBArray #-} + + +-- Mutable Small Boxed Array -- +------------------------------- + +-- | Small boxed mutable array +data SBMArray e s = SBMArray (SmallMutableArray# s e) + +-- | Check if both of the arrays refer to the exact same one. None of the elements are +-- evaluated. +instance Eq (SBMArray e s) where + (==) = isSameSBMArray + {-# INLINE (==) #-} + + +-- | Compare pointers for two mutable arrays and see if they refer to the exact same one. +-- +-- Documentation for utilized primop: `sameSmallMutableArray#`. +-- +-- @since 0.3.0 +isSameSBMArray :: forall a s. SBMArray a s -> SBMArray a s -> Bool +isSameSBMArray (SBMArray ma1#) (SBMArray ma2#) = + isTrue# (sameSmallMutableArray# ma1# ma2#) +{-# INLINE isSameSBMArray #-} + + +-- | /O(1)/ - Get the size of a mutable boxed array +-- +-- Documentation for utilized primop: `getSizeofSmallMutableArray#` for ghc-8.10 and newer +-- and fallback to `sizeofMutableArray#` for older versions. +-- +-- ====__Example__ +-- +-- >>> ma <- newSBMArray 1024 "Element of each cell" +-- >>> getSizeOfSBMArray ma +-- Size {unSize = 1024} +-- +-- @since 0.3.0 +getSizeOfSBMArray :: forall e m s. MonadPrim s m => SBMArray e s -> m Size +getSizeOfSBMArray (SBMArray ma#) = + prim $ \s -> + case getSizeofSmallMutableArray# ma# s of + (# s', i# #) -> (# s', coerce (I# i#) #) +{-# INLINE getSizeOfSBMArray #-} + +-- | /O(1)/ - Read an element from a mutable small boxed array at the supplied index. +-- +-- Documentation for utilized primop: `readSmallArray#`. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in undefined behavior or a failure +-- with a segfault +-- +-- ==== __Example__ +-- +-- >>> ma <- makeSBMArray 10 (pure . ("Element ix: " ++) . show) +-- >>> readSBMArray ma 5 +-- "Element ix: 5" +-- +-- @since 0.1.0 +readSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /srcMutArray/ - Array to read an element from + -> Int + -- ^ /ix/ - Index that refers to an element we need within the the @srcMutArray@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfMSBArray srcMutArray) + -> m e +readSBMArray (SBMArray ma#) (I# i#) = prim (readSmallArray# ma# i#) +{-# INLINE readSBMArray #-} + + + +-- | /O(1)/ - Write an element @elt@ into the mutable small boxed array @dstMutArray@ at +-- the supplied index @ix@. The actual element will be evaluated to WHNF prior to +-- mutation. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in heap corruption or a failure +-- with a segfault +-- +-- ==== __Examples__ +-- +-- >>> ma <- newSBMArray 4 (Nothing :: Maybe Integer) +-- >>> writeSBMArray ma 2 (Just 2) +-- >>> freezeSBMArray ma +-- SBArray [Nothing,Nothing,Just 2,Nothing] +-- +-- It is important to note that an element is evaluated prior to being written into a +-- cell, so it will not overwrite the value of an array's cell if it evaluates to an +-- exception: +-- +-- >>> import Control.Prim.Exception +-- >>> writeSBMArray ma 2 (impureThrow DivideByZero) +-- *** Exception: divide by zero +-- >>> freezeSBMArray ma +-- SBArray [Nothing,Nothing,Just 2,Nothing] +-- +-- However, it is evaluated only to Weak Head Normal Form (WHNF), so it is still possible +-- to write something that eventually evaluates to bottom. +-- +-- >>> writeSBMArray ma 3 (Just (7 `div` 0 )) +-- >>> freezeSBMArray ma +-- SBArray [Nothing,Nothing,Just 2,Just *** Exception: divide by zero +-- +-- Either `deepseq` or `writeDeepSBMArray` can be used to alleviate that. +-- +-- @since 0.3.0 +writeSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /dstMutArray/ - An array to have the element written to + -> Int + -- ^ /ix/ - Index within the the @dstMutArray@ that a refernce to the supplied element + -- @elt@ will be written to. + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfMSBArray srcArray) + -> e + -- ^ /elt/ - Element to be written into @dstMutArray@ + -> m () +writeSBMArray ma i !x = writeLazySBMArray ma i x +{-# INLINE writeSBMArray #-} + + +-- | /O(1)/ - Same as `writeSBMArray` but allows to write a thunk into an array instead of an +-- evaluated element. Careful with memory leaks and thunks that evaluate to exceptions. +-- +-- Documentation for utilized primop: `writeSmallArray#`. +-- +-- [Unsafe] Same reasons as `writeSBMArray` +-- +-- @since 0.3.0 +writeLazySBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s + -> Int + -> e + -> m () +writeLazySBMArray (SBMArray ma#) (I# i#) a = prim_ (writeSmallArray# ma# i# a) +{-# INLINE writeLazySBMArray #-} + + +-- | /O(1)/ - Same as `writeSBMArray`, except it ensures that the value being written is +-- fully evaluated, i.e. to Normal Form (NF). +-- +-- [Unsafe] Same reasons as `writeSBMArray` +-- +-- @since 0.3.0 +writeDeepSBMArray :: + forall e m s. (MonadPrim s m, NFData e) + => SBMArray e s + -> Int + -> e + -> m () +writeDeepSBMArray ma i !x = + case rnf x of + () -> writeLazySBMArray ma i x +{-# INLINE writeDeepSBMArray #-} + + + +-- | Create a mutable boxed array where each element is set to the supplied initial value +-- @elt@, which is evaluated before array allocation happens. See `newLazySBMArray` for +-- an ability to initialize with a thunk. +-- +-- [Unsafe size] Violation of precondition for the @sz@ argument can result in the current +-- thread being killed with `HeapOverflow` asynchronous exception or death of the whole +-- process with some unchecked exception from RTS. +-- +-- ====__Examples__ +-- +-- >>> newSBMArray 10 'A' >>= freezeSBMArray +-- SBArray "AAAAAAAAAA" +-- +-- @since 0.3.0 +newSBMArray :: + forall e m s. MonadPrim s m + => Size + -- ^ /sz/ - Size of the array + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> e -- ^ /elt/ - Value to use for all array cells + -> m (SBMArray e s) +newSBMArray sz x = x `seq` newLazySBMArray sz x +{-# INLINE newSBMArray #-} + +-- | Same as `newSBMArray`, except initial element is allowed to be a thunk. +-- +-- Documentation for utilized primop: `newSmallArray#`. +-- +-- [Unsafe] Same reasons as `newSBMArray` +-- +-- @since 0.3.0 +newLazySBMArray :: + forall e m s. MonadPrim s m + => Size + -> e + -> m (SBMArray e s) +newLazySBMArray (Size (I# n#)) a = + prim $ \s -> + case newSmallArray# n# a s of + (# s', ma# #) -> (# s', SBMArray ma# #) +{-# INLINE newLazySBMArray #-} + + + + +-- | Create new mutable array, where each element is initilized to a thunk that throws an +-- error when evaluated. This is useful when there is a plan to later iterate over the whole +-- array and write values into each cell in some index aware fashion. Consider `makeSBMArray` +-- as an alternative. +-- +-- [Partial] All array cells are initialized with thunks that throw `UndefinedElement` +-- exception. +-- +-- [Unsafe] Same reasons as `newSBMArray` +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim +-- >>> let xs = "Hello Haskell" +-- >>> ma <- newRawSBMArray (Size (length xs)) :: IO (SBMArray Char RW) +-- >>> mapM_ (\(i, x) -> writeSBMArray ma i x) (zip [0..] xs) +-- >>> freezeSBMArray ma +-- SBArray "Hello Haskell" +-- +-- @since 0.3.0 +newRawSBMArray :: + forall e m s. (HasCallStack, MonadPrim s m) + => Size + -> m (SBMArray e s) +newRawSBMArray sz = newLazySBMArray sz (uninitialized "Data.Prim.Aray" "newRawSBMArray") +{-# INLINE newRawSBMArray #-} + + + +-- | Create new mutable boxed array of the supplied size and fill it with a monadic action +-- that is applied to indices of each array cell. +-- +-- [Unsafe] Same reasons as `newSBMArray` +-- +-- ====__Examples__ +-- +-- >>> ma <- makeSBMArray 5 $ \i -> (toEnum (i + 97) :: Char) <$ putStrLn ("Handling index: " ++ show i) +-- Handling index: 0 +-- Handling index: 1 +-- Handling index: 2 +-- Handling index: 3 +-- Handling index: 4 +-- >>> freezeSBMArray ma +-- SBArray "abcde" +-- +-- @since 0.3.0 +makeSBMArray :: + forall e m s. MonadPrim s m + => Size + -> (Int -> m e) + -> m (SBMArray e s) +makeSBMArray = makeMutWith newRawSBMArray writeSBMArray +{-# INLINE makeSBMArray #-} + + +-- | /O(1)/ - Convert a mutable boxed array into an immutable one. Use `thawSBArray` in order +-- to go in the opposite direction. +-- +-- Documentation for utilized primop: `unsafeFreezeSmallArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the source mutable boxed array will also be reflected +-- in the resulting immutable array. See `freezeCopySBMArray` that avoids this problem with +-- fresh allocation. +-- +-- @since 0.3.0 +freezeSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s + -> m (SBArray e) +freezeSBMArray (SBMArray ma#) = prim $ \s -> + case unsafeFreezeSmallArray# ma# s of + (# s', a# #) -> (# s', SBArray a# #) +{-# INLINE freezeSBMArray #-} + + + +-- | /O(sz)/ - Similar to `freezeSBMArray`, except it creates a new array with the copy of a +-- subsection of a mutable array before converting it into an immutable. +-- +-- Documentation for utilized primop: `freezeSmallArray#`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault or out of memory exception. +-- +-- @since 0.3.0 +freezeCopySBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s + -- ^ /srcArray/ - Source mutable array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfSBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned immutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfSBArray srcArray) + -- + -- Should be less then actual available memory + -> m (SBArray e) +freezeCopySBMArray (SBMArray ma#) (I# i#) (Size (I# n#)) = prim $ \s -> + case freezeSmallArray# ma# i# n# s of + (# s', a# #) -> (# s', SBArray a# #) +{-# INLINE freezeCopySBMArray #-} + +-- | /O(sz)/ - Allocate a new small boxed mutable array of size @sz@ and copy that number +-- of the elements over from the @srcArray@ starting at index @ix@. Similar to +-- `cloneSBArray`, except that it works on mutable arrays. +-- +-- Documentation for utilized primop: `cloneSmallMutableArray#`. +-- +-- [Unsafe] When any of the preconditions for @startIx@ or @sz@ is violated this function +-- can result in a copy of some data that doesn't belong to @srcArray@ or more likely a +-- failure with a segfault. Failure with out of memory is also a possibility when the @sz is +-- too large. +-- +-- @since 0.3.0 +cloneSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s + -- ^ /srcArray/ - Source mutable array + -> Int + -- ^ /startIx/ - Location within @srcArray@ where the copy of elements should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= startIx + -- + -- > startIx < unSize (sizeOfSBArray srcArray) + -> Size + -- ^ /sz/ - Size of the returned mutable array. Also this is the number of elements that + -- will be copied over into the destionation array starting at the beginning. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > startIx + unSize sz < unSize (sizeOfSBArray srcArray) + -- + -- Should be less then actual available memory + -> m (SBMArray e s) +cloneSBMArray (SBMArray ma#) (I# i#) (Size (I# n#)) = + prim $ \s -> + case cloneSmallMutableArray# ma# i# n# s of + (# s', ma'# #) -> (# s', SBMArray ma'# #) +{-# INLINE cloneSBMArray #-} + + +-- | /O(sz)/ - Copy a subsection of a mutable array into a subsection of another or the same +-- mutable array. Therefore, unlike `copySBArray`, memory ia allowed to overlap between source +-- and destination. +-- +-- Documentation for utilized primop: `copySmallMutableArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or more +-- likely a failure with a segfault. +-- +-- @since 0.3.0 +moveSBMArray :: + forall e m s. MonadPrim s m + => SBMArray e s -- ^ /srcMutArray/ - Source mutable array + -> Int + -- ^ /srcStartIx/ - Offset into the source mutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcSize <- getSizeOfSBMArray srcMutArray + -- > srcStartIx < unSize srcSize + -> SBMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where copy should start to + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfSBMArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcSize <- getSizeOfSBMArray srcMutArray + -- > srcStartIx + unSize sz < unSize srcSize + -- + -- > dstSize <- getSizeOfSBMArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -- + -> m () +moveSBMArray (SBMArray src#) (I# srcOff#) (SBMArray dst#) (I# dstOff#) (Size (I# n#)) = + prim_ (copySmallMutableArray# src# srcOff# dst# dstOff# n#) +{-# INLINE moveSBMArray #-} + + + +------------------- +-- Unboxed Array -- +-- ============= -- + + +-- Immutable Unboxed Array -- +----------------------------- + +data UArray e = UArray ByteArray# +type role UArray nominal + +instance (Prim e, Show e) => Show (UArray e) where + showsPrec n arr + | n > 1 = ('(' :) . inner . (')' :) + | otherwise = inner + where + inner = ("UArray " ++) . shows (toList arr) + +instance Prim e => IsList (UArray e) where + type Item (UArray e) = e + fromList = fromListUArray + {-# INLINE fromList #-} + fromListN n = fromListUArrayN (coerce n) + {-# INLINE fromListN #-} + toList = toListUArray + {-# INLINE toList #-} + +instance e ~ Char => IsString (UArray e) where + fromString = fromListUArray + {-# INLINE fromString #-} + +-- | /O(1)/ - `UArray` is always in NF +instance NFData (UArray e) where + rnf (UArray _) = () + {-# INLINE rnf #-} + +instance (Prim e, Eq e) => Eq (UArray e) where + (==) = eqWith isSameUArray sizeOfUArray indexUArray + {-# INLINE (==) #-} + +instance (Prim e, Ord e) => Ord (UArray e) where + compare = compareWith isSameUArray sizeOfUArray indexUArray + {-# INLINE compare #-} + + +instance Prim e => Semigroup (UArray e) where + (<>) = appendWith newRawUMArray copyUArray freezeUMArray sizeOfUArray + {-# INLINE (<>) #-} + sconcat xs = concatWith newRawUMArray copyUArray freezeUMArray sizeOfUArray (NE.toList xs) + {-# INLINE sconcat #-} + stimes n = cycleWith newRawUMArray copyUArray freezeUMArray sizeOfUArray (fromIntegral n) + {-# INLINE stimes #-} + +instance Prim e => Monoid (UArray e) where + mempty = runST $ newRawUMArray 0 >>= freezeUMArray + {-# NOINLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat = concatWith newRawUMArray copyUArray freezeUMArray sizeOfUArray + {-# INLINE mconcat #-} + + +-- | /O(1)/ - Compare pointers for two immutable arrays and see if they refer to the exact same one. +-- +-- Documentation for utilized primop: `isSameByteArray#`. +-- +-- @since 0.3.0 +isSameUArray :: forall a b. UArray a -> UArray b -> Bool +isSameUArray (UArray ma1#) (UArray ma2#) = isTrue# (isSameByteArray# ma1# ma2#) +{-# INLINE isSameUArray #-} + + +-- | /O(1)/ - Check if memory for immutable unboxed array was allocated as pinned. +-- +-- Documentation for utilized primop: `isByteArrayPinned#`. +-- +-- @since 0.3.0 +isPinnedUArray :: forall e. UArray e -> Bool +isPinnedUArray (UArray b#) = isTrue# (isByteArrayPinned# b#) +{-# INLINE isPinnedUArray #-} + + + +-- | /O(1)/ - Get the size of an immutable array in number of elements. +-- +-- Documentation for utilized primop: `sizeofByteArray#`. +-- +-- @since 0.3.0 +sizeOfUArray :: + forall e. Prim e + => UArray e + -> Size +sizeOfUArray (UArray a#) = + coerce (fromByteCount (coerce (I# (sizeofByteArray# a#))) :: Count e) +{-# INLINE sizeOfUArray #-} + + +-- | /O(1)/ - Index an element of a pure unboxed array. +-- +-- Documentation for utilized primop: `indexByteArray#`. +-- +-- [Unsafe] Bounds are not checked. When a precondition for @ix@ argument is violated the +-- result is either unpredictable output or failure with a segfault. +-- +-- ==== __Examples__ +-- +-- >>> let a = fromListUArray ([Left pi, Right 123] :: [Either Double Int]) +-- >>> indexUArray a 0 +-- Left 3.141592653589793 +-- >>> indexUArray a 1 +-- Right 123 +-- +-- @since 0.3.0 +indexUArray :: + forall e. Prim e + => UArray e + -- ^ /array/ - Array where to lookup an element from + -> Int + -- ^ /ix/ - Position of the element within the @array@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > ix < unSize (sizeOfUArray array) + -> e +indexUArray (UArray a#) (I# i#) = indexByteArray# a# i# +{-# INLINE indexUArray #-} + + +-- | /O(sz)/ - Copy a subsection of an immutable array into a subsection of another mutable +-- array. Source and destination arrays must not be the same array in different states. +-- +-- Documentation for utilized primop: `copyByteArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or +-- failure with a segfault. +-- +-- @since 0.3.0 +copyUArray :: + forall e m s. (Prim e, MonadPrim s m) + => UArray e + -- ^ /srcArray/ - Source immutable array + -- + -- /__Precondition:__/ + -- + -- > srcMutArray <- thawUArray srcArray + -- > srcMutArray /= dstMutArray + -> Int + -- ^ /srcStartIx/ - Offset into the source immutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcStartIx < unSize (sizeOfUArray srcArray) + -> UMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where the copy should start + -- at + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcStartIx + unSize sz < unSize (sizeOfUArray srcArray) + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -> m () +copyUArray (UArray src#) srcOff (UMArray dst#) dstOff n = + let srcOff# = unOffBytes# (coerce srcOff :: Off e) + dstOff# = unOffBytes# (coerce dstOff :: Off e) + n# = unCountBytes# (coerce n :: Count e) + in prim_ (copyByteArray# src# srcOff# dst# dstOff# n#) +{-# INLINE copyUArray #-} + + +-- | /O(1)/ - Convert a pure immutable unboxed array into a mutable unboxed array. Use +-- `freezeUMArray` in order to go in the opposite direction. +-- +-- Documentation for utilized primop: `unsafeThawByteArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the mutable unboxed array will also be reflected in +-- the source immutable array as well. +-- +-- ====__Examples__ +-- +-- >>> ma <- thawUArray $ fromListUArray [1 .. 5 :: Int] +-- >>> writeUMArray ma 1 10 +-- >>> freezeUMArray ma +-- UArray [1,10,3,4,5] +-- +-- Be careful not to retain a reference to the pure immutable source array after the +-- thawed version gets mutated. +-- +-- >>> let a = fromListUArray [1 .. 5 :: Int] +-- >>> ma' <- thawUArray a +-- >>> writeUMArray ma' 0 100000 +-- >>> a +-- UArray [100000,2,3,4,5] +-- +-- @since 0.3.0 +thawUArray :: forall e m s. MonadPrim s m => UArray e -> m (UMArray e s) +thawUArray (UArray a#) = + prim $ \s -> + case unsafeThawByteArray# a# s of + (# s', ma# #) -> (# s', UMArray ma# #) +{-# INLINE thawUArray #-} + + + +-- | /O(n)/ - Convert a pure boxed array into a list. It should work fine with GHC built-in list +-- fusion. +-- +-- @since 0.1.0 +toListUArray :: + forall e. Prim e + => UArray e + -> [e] +toListUArray ba = build (\ c n -> foldrWithFB sizeOfUArray indexUArray c n ba) +{-# INLINE toListUArray #-} + +-- | /O(min(length list, sz))/ - Same as `fromListUArray`, except it will allocate an array exactly of @n@ size, as +-- such it will not convert any portion of the list that doesn't fit into the newly +-- created array. +-- +-- [Partial] When length of supplied list is in fact smaller then the expected size @sz@, +-- thunks with `UndefinedElement` exception throwing function will be placed in the tail +-- portion of the array. +-- +-- [Unsafe] When a precondition @sz@ is violated this function can result in critical +-- failure with out of memory or `HeapOverflow` async exception. +-- +-- ====__Examples__ +-- +-- >>> fromListUArrayN 3 [1 :: Int, 2, 3] +-- UArray [1,2,3] +-- >>> fromListUArrayN 3 [1 :: Int ..] +-- UArray [1,2,3] +-- +-- @since 0.1.0 +fromListUArrayN :: + forall e. Prim e + => Size -- ^ /sz/ - Expected number of elements in the @list@ + -> [e] -- ^ /list/ - A list to bew loaded into the array + -> UArray e +fromListUArrayN sz xs = + runST $ fromListMutWith newRawUMArray writeUMArray sz xs >>= freezeUMArray +{-# INLINE fromListUArrayN #-} + + +-- | /O(length list)/ - Convert a list into an immutable boxed array. It is more efficient to use +-- `fromListUArrayN` when the number of elements is known ahead of time. The reason for this +-- is that it is necessary to iterate the whole list twice: once to count how many elements +-- there is in order to create large enough array that can fit them; and the second time to +-- load the actual elements. Naturally, infinite lists will grind the program to a halt. +-- +-- ====__Example__ +-- +-- >>> fromListUArray "Hello Haskell" +-- UArray "Hello Haskell" +-- +-- @since 0.3.0 +fromListUArray :: + forall e. Prim e + => [e] + -> UArray e +fromListUArray xs = fromListUArrayN (coerce (length xs)) xs +{-# INLINE fromListUArray #-} + +-- | /O(1)/ - cast an unboxed `A.UArray` that is wired with GHC to `UArray` from primal. +-- +-- >>> import Data.Array.IArray as IA +-- >>> import Data.Array.Unboxed as UA +-- >>> let uarr = IA.listArray (10, 15) [30 .. 35] :: UA.UArray Int Word +-- >>> uarr +-- array (10,15) [(10,30),(11,31),(12,32),(13,33),(14,34),(15,35)] +-- >>> fromBaseUArray uarr +-- UArray [30,31,32,33,34,35] +-- +-- @since 0.3.0 +fromBaseUArray :: (Prim e, A.IArray A.UArray e) => A.UArray ix e -> UArray e +fromBaseUArray (A.UArray _ _ _ ba#) = UArray ba# + +-- | /O(1)/ - cast an unboxed `UArray` from primal into `A.UArray`, which is wired with +-- GHC. Resulting array range starts at 0, like any sane array would. +-- +-- >>> let uarr = fromListUArray [1, 2, 3 :: Int] +-- >>> uarr +-- UArray [1,2,3] +-- >>> toBaseUArray uarr +-- array (0,2) [(0,1),(1,2),(2,3)] +-- +-- @since 0.3.0 +toBaseUArray :: (Prim e, A.IArray A.UArray e) => UArray e -> A.UArray Int e +toBaseUArray a@(UArray ba#) = + let Size n = sizeOfUArray a + in A.UArray 0 (max 0 (n - 1)) n ba# + +-- Mutable Unboxed Array -- +--------------------------- + +data UMArray e s = UMArray (MutableByteArray# s) +type role UMArray nominal nominal + +-- | Check if both of the arrays refer to the exact same one through poiner equality. None +-- of the elements are evaluated. +instance Eq (UMArray e s) where + (==) = isSameUMArray + {-# INLINE (==) #-} + +-- | /O(1)/ - `UMArray` is always in NF +instance NFData (UMArray e s) where + rnf (UMArray _) = () + {-# INLINE rnf #-} + +-- | /O(1)/ - Compare pointers for two mutable arrays and see if they refer to the exact same one. +-- +-- Documentation for utilized primop: `sameMutableByteArray#`. +-- +-- @since 0.3.0 +isSameUMArray :: forall a b s. UMArray a s -> UMArray b s -> Bool +isSameUMArray (UMArray ma1#) (UMArray ma2#) = isTrue# (sameMutableByteArray# ma1# ma2#) +{-# INLINE isSameUMArray #-} + + +-- | /O(1)/ - Check if memory for mutable unboxed array was allocated as pinned. +-- +-- Documentation for utilized primop: `isMutableByteArrayPinned#`. +-- +-- @since 0.3.0 +isPinnedUMArray :: forall e s. UMArray e s -> Bool +isPinnedUMArray (UMArray mb#) = isTrue# (isMutableByteArrayPinned# mb#) +{-# INLINE isPinnedUMArray #-} + +-- | /O(1)/ - Get the size of a mutable unboxed array +-- +-- Documentation for utilized primop: `getSizeofMutableByteArray#`. +-- +-- ====__Example__ +-- +-- >>> ma <- thawUArray $ fromListUArray ['a' .. 'z'] +-- >>> getSizeOfUMArray ma +-- Size {unSize = 26} +-- +-- @since 0.3.0 +getSizeOfUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => UMArray e s + -> m Size +getSizeOfUMArray (UMArray ma#) = + prim $ \s -> + case getSizeofMutableByteArray# ma# s of + (# s', n# #) -> (# s', coerce (fromByteCount (Count (I# n#)) :: Count e) #) +{-# INLINE getSizeOfUMArray #-} + + + +-- | /O(1)/ - Read an element from a mutable unboxed array at the supplied index. +-- +-- Documentation for utilized primop: `readMutableByteArray#`. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in value that doesn't belong to +-- @srcMutArray@ or a failure with a segfault +-- +-- ==== __Examples__ +-- +-- >>> ma <- thawUArray $ fromListUArray "Hi!" +-- >>> readUMArray ma 2 +-- '!' +-- +-- @since 0.3.0 +readUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => UMArray e s -- ^ /srcMutArray/ - Array to read an element from + -> Int + -- ^ /ix/ - Index for the element we need within the the @srcMutArray@ + -- + -- /__Precoditions:__/ + -- + -- > 0 <= ix + -- + -- > srcSize <- getSizeOfMUArray srcMutArray + -- > ix < unSize srcSize + -> m e +readUMArray (UMArray ma#) (I# i#) = prim (readMutableByteArray# ma# i#) +{-# INLINE readUMArray #-} + + +-- | /O(1)/ - Write an element into an unboxed mutable array at a supplied index. +-- +-- Documentation for utilized primop: `writeMutableByteArray#`. +-- +-- [Unsafe] Violation of @ix@ preconditions can result in heap corruption or a failure +-- with a segfault +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim +-- >>> ma <- newRawUMArray 4 :: IO (UMArray (Maybe Int) RW) +-- >>> mapM_ (\i -> writeUMArray ma i Nothing) [0, 1, 3] +-- >>> writeUMArray ma 2 (Just 2) +-- >>> freezeUMArray ma +-- UArray [Nothing,Nothing,Just 2,Nothing] +-- +-- @since 0.3.0 +writeUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => UMArray e s + -> Int + -> e + -> m () +writeUMArray (UMArray ma#) (I# i#) a = prim_ (writeMutableByteArray# ma# i# a) +{-# INLINE writeUMArray #-} + +-- prop> newUMArray sz a === makeUMArray sz (const (pure a)) +-- | /O(sz)/ - Allocate new mutable unboxed array. Similar to `newRawUMArray`, except all +-- elements are initialized to the supplied initial value. This is equivalent to +-- @makeUMArray sz (const (pure a))@ but often will be more efficient. +-- +-- [Unsafe] When any of preconditions for @sz@ argument is violated the outcome is +-- unpredictable. One possible outcome is termination with `HeapOverflow` async +-- exception. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim +-- >>> let xs = "Hello" +-- >>> ma <- newUMArray (Size (length xs) + 8) '!' :: IO (UMArray Char RW) +-- >>> mapM_ (\(i, x) -> writeUMArray ma i x) (zip [0..] xs) +-- >>> freezeUMArray ma +-- UArray "Hello!!!!!!!!" +-- +-- @since 0.3.0 +newUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -- ^ /sz/ - Size of the array in number of elements. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Susceptible to integer overflow: + -- + -- > 0 <= toByteCount (Count (unSize n) :: Count e) + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> e + -> m (UMArray e s) +newUMArray n e = newRawUMArray n >>= \ma -> ma <$ setUMArray ma 0 n e +{-# INLINE newUMArray #-} + + +-- | Same `newUMArray`, but allocate memory as pinned. See `newRawPinnedUMArray` for more info. +-- +-- [Unsafe] - Same reasons as `newUMArray`. +-- +-- @since 0.3.0 +newPinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> e + -> m (UMArray e s) +newPinnedUMArray n e = newRawPinnedUMArray n >>= \ma -> ma <$ setUMArray ma 0 n e +{-# INLINE newPinnedUMArray #-} + + +-- | Same `newUMArray`, but allocate memory as pinned and aligned. See +-- `newRawAlignedPinnedUMArray` for more info. +-- +-- [Unsafe] - Same reasons as `newUMArray`. +-- +-- @since 0.3.0 +newAlignedPinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> e + -> m (UMArray e s) +newAlignedPinnedUMArray n e = newRawAlignedPinnedUMArray n >>= \ma -> ma <$ setUMArray ma 0 n e +{-# INLINE newAlignedPinnedUMArray #-} + + + +-- | Create new mutable unboxed array of the supplied size and fill it with a monadic action +-- that is applied to indices of each array cell. +-- +-- [Unsafe] Same reasons as `newUMArray` +-- +-- ====__Examples__ +-- +-- >>> ma <- makeUMArray 5 $ \i -> (toEnum (i + 97) :: Char) <$ putStrLn ("Handling index: " ++ show i) +-- Handling index: 0 +-- Handling index: 1 +-- Handling index: 2 +-- Handling index: 3 +-- Handling index: 4 +-- >>> freezeUMArray ma +-- UArray "abcde" +-- +-- @since 0.3.0 +makeUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> (Int -> m e) + -> m (UMArray e s) +makeUMArray = makeMutWith newRawUMArray writeUMArray +{-# INLINE makeUMArray #-} + + +-- | Same as `makeUMArray`, but allocate memory as pinned. +-- +-- [Unsafe] Same reasons as `newUMArray` +-- +-- @since 0.3.0 +makePinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> (Int -> m e) + -> m (UMArray e s) +makePinnedUMArray = makeMutWith newRawPinnedUMArray writeUMArray +{-# INLINE makePinnedUMArray #-} + +-- | Same as `makeUMArray`, but allocate memory as pinned and aligned. +-- +-- [Unsafe] Same reasons as `newUMArray` +-- +-- @since 0.3.0 +makeAlignedPinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> (Int -> m e) + -> m (UMArray e s) +makeAlignedPinnedUMArray = makeMutWith newRawAlignedPinnedUMArray writeUMArray +{-# INLINE makeAlignedPinnedUMArray #-} + + +-- | /O(1)/ - Allocate new mutable unboxed array. None of the elements are initialized so +-- expect it to contain some random garbage. +-- +-- Documentation for utilized primop: `newByteArray#`. +-- +-- [Unsafe] When any of preconditions for @sz@ argument is violated the outcome is +-- unpredictable. One possible outcome is termination with `HeapOverflow` async +-- exception. In a pure setting, such as when executed within `runST`, if each cell in new +-- array is not overwritten it can lead to violation of referential transparency, because +-- contents of newly allocated unboxed array is non-determinstic. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim +-- >>> let xs = "Hello Haskell" +-- >>> ma <- newRawUMArray (Size (length xs)) :: IO (UMArray Char RW) +-- >>> mapM_ (\(i, x) -> writeUMArray ma i x) (zip [0..] xs) +-- >>> freezeUMArray ma +-- UArray "Hello Haskell" +-- +-- @since 0.3.0 +newRawUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -- ^ /sz/ - Size of the array in number of elements. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Susceptible to integer overflow: + -- + -- > 0 <= toByteCount (Count (unSize n) :: Count e) + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> m (UMArray e s) +newRawUMArray n = + prim $ \s -> + case newByteArray# (unCountBytes# (coerce n :: Count e)) s of + (# s', ma# #) -> (# s', UMArray ma# #) +{-# INLINE newRawUMArray #-} + +-- | /O(1)/ - Same as `newRawUMArray` except allocate new mutable unboxed array as pinned +-- +-- Documentation for utilized primop: `newPinnedByteArray#`. +-- +-- [Unsafe] Same reasons as in `newRawUMArray`. +-- +-- @since 0.3.0 +newRawPinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> m (UMArray e s) +newRawPinnedUMArray n = + prim $ \s -> + case newPinnedByteArray# (unCountBytes# (coerce n :: Count e)) s of + (# s', ma# #) -> (# s', UMArray ma# #) +{-# INLINE newRawPinnedUMArray #-} + +-- | /O(1)/ - Same as `newRawPinnedUMArray` except allocate new mutable unboxed array as +-- pinned and aligned according to the `Prim` instance for the type of element @__e__@ +-- +-- Documentation for utilized primop: `newAlignedPinnedByteArray#`. +-- +-- [Unsafe] Same reasons as in `newRawUMArray`. +-- +-- @since 0.3.0 +newRawAlignedPinnedUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => Size + -> m (UMArray e s) +newRawAlignedPinnedUMArray n = + prim $ \s -> + let c# = unCountBytes# (coerce n :: Count e) + a# = alignment# (proxy# :: Proxy# e) + in case newAlignedPinnedByteArray# c# a# s of + (# s', ma# #) -> (# s', UMArray ma# #) +{-# INLINE newRawAlignedPinnedUMArray #-} + + +-- | /O(sz)/ - Copy a subsection of a mutable array into a subsection of another or the same +-- mutable array. Therefore, unlike `copyBArray`, memory ia allowed to overlap between +-- source and destination. +-- +-- Documentation for utilized primop: `copyMutableByteArray#`. +-- +-- [Unsafe] When any of the preconditions for @srcStartIx@, @dstStartIx@ or @sz@ is violated +-- this function can result in a copy of some data that doesn't belong to @srcArray@ or +-- failure with a segfault. +-- +-- @since 0.3.0 +moveUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => UMArray e s -- ^ /srcMutArray/ - Source mutable array + -> Int + -- ^ /srcStartIx/ - Offset into the source mutable array where copy should start from + -- + -- /__Preconditions:__/ + -- + -- > 0 <= srcStartIx + -- + -- > srcSize <- getSizeOfMUArray srcMutArray + -- > srcStartIx < unSize srcSize + -> UMArray e s -- ^ /dstMutArray/ - Destination mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the destination mutable array where copy should start to + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /sz/ - Number of elements to copy over + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > srcSize <- getSizeOfMUArray srcMutArray + -- > srcStartIx + unSize sz < unSize srcSize + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx + unSize sz < unSize dstSize + -> m () +moveUMArray (UMArray src#) srcOff (UMArray dst#) dstOff n = + let srcOff# = unOffBytes# (coerce srcOff :: Off e) + dstOff# = unOffBytes# (coerce dstOff :: Off e) + n# = unCountBytes# (coerce n :: Count e) + in prim_ (copyMutableByteArray# src# srcOff# dst# dstOff# n#) +{-# INLINE moveUMArray #-} + + +-- | /O(n)/ - Write the same element into the @dstMutArray@ mutable array @n@ times starting +-- at @dstStartIx@ offset. +-- +-- [Unsafe] +-- +-- @since 0.3.0 +setUMArray :: + forall e m s. (Prim e, MonadPrim s m) + => UMArray e s -- ^ /dstMutArray/ - Mutable array + -> Int + -- ^ /dstStartIx/ - Offset into the mutable array + -- + -- /__Preconditions:__/ + -- + -- > 0 <= dstStartIx + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx < unSize dstSize + -> Size + -- ^ /n/ - Number of elements to overwrite + -- + -- /__Preconditions:__/ + -- + -- > 0 <= n + -- + -- > dstSize <- getSizeOfMUArray dstMutArray + -- > dstStartIx + unSize n < unSize dstSize + -> e -- ^ /elt/ - Value to overwrite the cells with in the specified block + -> m () +setUMArray (UMArray ma#) (I# o#) (Size (I# n#)) a = + prim_ (setMutableByteArray# ma# o# n# a) +{-# INLINE setUMArray #-} + + +-- | /O(1)/ - Reduce the size of a mutable unboxed array. +-- +-- Documentation for utilized primop: `shrinkMutableByteArray#`. +-- +-- [Unsafe] - Violation of preconditions for @sz@ leads to undefined behavior +-- +-- 0.3.0 +shrinkUMArray :: + forall e m s. (MonadPrim s m, Prim e) + => UMArray e s -- ^ /mutArray/ - Mutable unboxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- > curSize <- getSizeOfUMArray mutArray + -- > sz <= curSize + -> m () +shrinkUMArray (UMArray mb#) sz = + prim_ (shrinkMutableByteArray# mb# (unCountBytes# (coerce sz :: Count e))) +{-# INLINE shrinkUMArray #-} + +-- | /O(1)/ - Either grow or shrink the size of a mutable unboxed array. Shrinking happens +-- without new allocation and data copy, while growing the array is implemented with +-- allocation of new unpinned array and copy of the data over from the source array +-- @srcMutArray@. This has a consequence that produced array @dstMutArray@ might refer to +-- the same @srcMutArray@ or to a totally new array, which can be checked with +-- `isSameUMArray`. +-- +-- Documentation on the utilized primop: `resizeMutableByteArray#`. +-- +-- [Unsafe] - Same reasons as in `newRawUMArray`. When size @sz@ is larger then the +-- size of @srcMutArray@ then @dstMutArray@ will contain uninitialized memory at its end, +-- hence a potential problem for referential transparency. +-- +-- 0.3.0 +resizeUMArray :: + forall e m s. (MonadPrim s m, Prim e) + => UMArray e s -- ^ /srcMutArray/ - Mutable unboxed array to be shrunk + -> Size + -- ^ /sz/ - New size for the array in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= sz + -- + -- Susceptible to integer overflow: + -- + -- > 0 <= toByteCount (Count (unSize n) :: Count e) + -- + -- Should be below some upper limit that is dictated by the operating system and the total + -- amount of available memory + -> m (UMArray e s) -- ^ /dstMutArray/ - produces a resized version of /srcMutArray/. +resizeUMArray (UMArray mb#) sz = + prim $ \s -> + case resizeMutableByteArray# mb# (unCountBytes# (coerce sz :: Count e)) s of + (# s', mb'# #) -> (# s', UMArray mb'# #) +{-# INLINE resizeUMArray #-} + + + +-- | /O(1)/ - Convert a mutable unboxed array into an immutable one. Use `thawUArray` in order +-- to go in the opposite direction. +-- +-- Documentation on the utilized primop: `unsafeFreezeByteArray#`. +-- +-- [Unsafe] This function makes it possible to break referential transparency, because any +-- subsequent destructive operation to the source mutable boxed array will also be reflected +-- in the resulting immutable array. See `freezeCopyBMArray` that avoids this problem with +-- fresh allocation. +-- +-- @since 0.3.0 +freezeUMArray :: + forall e m s. MonadPrim s m + => UMArray e s + -> m (UArray e) +freezeUMArray (UMArray ma#) = prim $ \s -> + case unsafeFreezeByteArray# ma# s of + (# s', a# #) -> (# s', UArray a# #) +{-# INLINE freezeUMArray #-} + +------------- +-- Helpers -- +-- ======= -- + +-- | Default "raw" element for boxed arrays. +uninitialized :: + HasCallStack + => String -- ^ Module name + -> String -- ^ Function name + -> a +uninitialized mname fname = + impureThrow $ + UndefinedElement $ mname ++ "." ++ fname ++ "\n" ++ prettyCallStack callStack +{-# NOINLINE uninitialized #-} + +-- | Convert a list to a mutable array +fromListMutWith :: + Monad m + => (Size -> m b) -- ^ Function for array creation + -> (b -> Int -> a -> m ()) -- ^ Function for writing elements + -> Size -- ^ Size for the created array + -> [a] -- ^ Function for generating elements from array index + -> m b +fromListMutWith new write sz@(Size n) ls = do + ma <- new sz + let go i = + \case + x:xs + | i < n -> write ma i x >> go (i + 1) xs + _ -> pure () + ma <$ go 0 ls +{-# INLINE fromListMutWith #-} + + +-- | Helper for generating mutable arrays +-- +-- @since 0.3.0 +makeMutWith :: + Monad m + => (Size -> m b) -- ^ Function for array creation + -> (b -> Int -> a -> m ()) -- ^ Function for writing elements + -> Size -- ^ Size for the created array + -> (Int -> m a) -- ^ Function for generating elements from array index + -> m b +makeMutWith new write sz@(Size n) f = do + ma <- new sz + let go i = when (i < n) $ f i >>= write ma i >> go (i + 1) + ma <$ go 0 +{-# INLINE makeMutWith #-} + + +-- | Right fold that is strict on the element. The key feature of this function is that it +-- can be used to convert an array to a list by integrating with list fusion using `build`. +-- +-- @since 0.3.0 +foldrWithFB :: + (a e -> Size) -- ^ Function that produces the size of an array + -> (a e -> Int -> e) -- ^ Indexing function + -> (e -> b -> b) -- ^ Folding functions + -> b -- ^ Initial accumulator + -> a e -- ^ Array to fold over + -> b +foldrWithFB size index c nil a = go 0 + where + k = coerce (size a) + go i + | i >= k = nil + | otherwise = + let v = index a i + in v `seq` (v `c` go (i + 1)) +{-# INLINE[0] foldrWithFB #-} + +-- | Check for equality of two arrays +-- +-- @since 0.3.0 +eqWith :: + Eq e + => (a e -> a e -> Bool) -- ^ Pointer equality + -> (a e -> Size) -- ^ Get the size of array + -> (a e -> Int -> e) -- ^ Index an element of an array + -> a e -- ^ First array + -> a e -- ^ Second array + -> Bool +eqWith isSame sizeOf index a1 a2 = isSame a1 a2 || (sz1 == sizeOf a2 && loop 0) + where + sz1@(Size n) = sizeOf a1 + loop i + | i < n = index a1 i == index a2 i && loop (i + 1) + | otherwise = True +{-# INLINE eqWith #-} + + + +-- | Check for equality of two arrays +-- +-- @since 0.3.0 +liftEqWith :: + (forall e. a e -> Size) -- ^ Get the size of array + -> (forall e. a e -> Int -> e) -- ^ Index an element of an array + -> (b -> c -> Bool) + -> a b -- ^ First array + -> a c -- ^ Second array + -> Bool +liftEqWith sizeOf index eq a1 a2 = sz1 == sizeOf a2 && loop 0 + where + sz1@(Size n) = sizeOf a1 + loop i + | i < n = (index a1 i `eq` index a2 i) && loop (i + 1) + | otherwise = True +{-# INLINE liftEqWith #-} + +liftShowsPrecArray :: Foldable f => String -> ([e] -> ShowS) -> Int -> f e -> ShowS +liftShowsPrecArray tyName listShows n arr + | n > 1 = ('(' :) . inner . (')' :) + | otherwise = inner + where + inner = (tyName ++) . (' ' :) . listShows (F.toList arr) + + +-- | Compare two arrays using supplied functions +-- +-- @since 0.3.0 +compareWith :: + Ord e + => (a e -> a e -> Bool) -- ^ Pointer equality + -> (a e -> Size) -- ^ Get the size of array + -> (a e -> Int -> e) -- ^ Index an element of an array + -> a e -- ^ First array + -> a e -- ^ Second array + -> Ordering +compareWith isSame sizeOf index a1 a2 + | isSame a1 a2 = EQ + | otherwise = loop 0 + where + Size n = min (sizeOf a1) (sizeOf a2) + loop i + | i < n = compare (index a1 i) (index a2 i) <> loop (i + 1) + | otherwise = compare (sizeOf a1) (sizeOf a2) +{-# INLINE compareWith #-} + + +-- | Compare two arrays using supplied functions +-- +-- @since 0.3.0 +liftCompareWith :: + (forall e. a e -> Size) -- ^ Get the size of array + -> (forall e. a e -> Int -> e) -- ^ Index an element of an array + -> (b -> c -> Ordering) + -> a b -- ^ First array + -> a c -- ^ Second array + -> Ordering +liftCompareWith sizeOf index comp a1 a2 = loop 0 + where + Size n = min (sizeOf a1) (sizeOf a2) + loop i + | i < n = comp (index a1 i) (index a2 i) <> loop (i + 1) + | otherwise = compare (sizeOf a1) (sizeOf a2) +{-# INLINE liftCompareWith #-} + +-- | Append two arrays together using supplied functions +-- +-- @since 0.3.0 +appendWith :: + (forall s. Size -> ST s (ma e s)) + -> (forall s. a e -> Int -> ma e s -> Int -> Size -> ST s ()) + -> (forall s. ma e s -> ST s (a e)) + -> (a e -> Size) + -> a e + -> a e + -> a e +appendWith newRaw copy freeze sizeOf a1 a2 = + runST $ do + let n1 = sizeOf a1 + n2 = sizeOf a2 + ma <- newRaw (n1 + n2) + copy a1 0 ma 0 n1 + copy a2 0 ma (coerce n1) n2 + freeze ma +{-# INLINE appendWith #-} + + +-- | Concat many arrays together using supplied functions +-- +-- @since 0.3.0 +concatWith :: + (forall s. Size -> ST s (ma e s)) + -> (forall s. a e -> Int -> ma e s -> Int -> Size -> ST s ()) + -> (forall s. ma e s -> ST s (a e)) + -> (a e -> Size) + -> [a e] + -> a e +concatWith newRaw copy freeze sizeOf xs = + runST $ do + let as = [(sizeOf a, a) | a <- xs] + !n = getSum $ foldMap (Sum . fst) as + ma <- newRaw n + let load i (sz, a) = (i + coerce sz) <$ copy a 0 ma i sz + foldM_ load 0 as + freeze ma +{-# INLINE concatWith #-} + + +-- | Repeat an array N times and concat them together using supplied functions +-- +-- @since 0.3.0 +cycleWith :: + Monoid (a e) + => (forall s. Size -> ST s (ma e s)) + -> (forall s. a e -> Int -> ma e s -> Int -> Size -> ST s ()) + -> (forall s. ma e s -> ST s (a e)) + -> (a e -> Size) + -> Int + -> a e + -> a e +cycleWith newRaw copy freeze sizeOf k a + | k <= 0 = mempty + | otherwise = + runST $ do + let sz@(Size n) = sizeOf a + ma <- newRaw (Size k * sz) + let load i = when (i < k) $ copy a 0 ma (i * n) sz >> load (i + 1) + load 0 + freeze ma +{-# INLINE cycleWith #-} diff --git a/src/Data/Prim/Atom.hs b/src/Data/Prim/Atom.hs --- a/src/Data/Prim/Atom.hs +++ b/src/Data/Prim/Atom.hs @@ -4,7 +4,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} @@ -24,7 +23,6 @@ , releaseLockByteOffMutableByteArray , acquireLockByteOffAddr , releaseLockByteOffAddr - -- ** Expirimental , withLockMutableByteArray , withLockOffAddr -- * Helpers and testing @@ -60,19 +58,33 @@ ) where import Control.DeepSeq -import Control.Exception -import Control.Monad -import Control.Prim.Monad +import Control.Prim.Concurrent +import Control.Prim.Exception import Control.Prim.Monad.Unsafe import Data.Bits import Data.Prim.Atomic import Data.Prim.Class import Foreign.Prim hiding (Any) -import GHC.IO import GHC.TypeLits -newtype Atom a = Atom { unAtom :: a } - deriving (Show, Eq, Ord, Num, Enum, Integral, Real, RealFrac, Fractional, Floating, RealFloat, Bits, NFData) +newtype Atom a = + Atom + { unAtom :: a + } + deriving ( Show + , Eq + , Ord + , Num + , Enum + , Integral + , Real + , RealFrac + , Fractional + , Floating + , RealFloat + , Bits + , NFData + ) instance Prim a => Prim (Atom a) where @@ -120,51 +132,47 @@ {-# INLINE setOffAddr# #-} -acquireLockByteOffMutableByteArray :: MutableByteArray# RealWorld -> Int# -> IO () +acquireLockByteOffMutableByteArray :: MonadPrim s m => MutableByteArray# s -> Int# -> m () acquireLockByteOffMutableByteArray mba# i# = let go = do - locked <- syncLockTestSetInt8ArrayIO mba# i# - when (locked == 0) go + locked <- unsafeIOToPrim $ syncLockTestSetInt8ArrayIO mba# i# + unless (locked == 0) $ yield >> go in go {-# INLINE acquireLockByteOffMutableByteArray #-} -releaseLockByteOffMutableByteArray :: MutableByteArray# RealWorld -> Int# -> IO () -releaseLockByteOffMutableByteArray mba# i# = syncLockReleaseInt8ArrayIO mba# i# +releaseLockByteOffMutableByteArray :: MonadPrim s m => MutableByteArray# s -> Int# -> m () +releaseLockByteOffMutableByteArray mba# i# = + unsafeIOToPrim $ syncLockReleaseInt8ArrayIO mba# i# {-# INLINE releaseLockByteOffMutableByteArray #-} -acquireLockByteOffAddr :: Addr# -> Int# -> IO () +acquireLockByteOffAddr :: MonadPrim s m => Addr# -> Int# -> m () acquireLockByteOffAddr addr# i# = let go = do - locked <- syncLockTestSetInt8AddrIO addr# i# - when (locked == 0) go + locked <- unsafeIOToPrim $ syncLockTestSetInt8AddrIO addr# i# + unless (locked == 0) $ yield >> go in go {-# INLINE acquireLockByteOffAddr #-} -releaseLockByteOffAddr :: Addr#-> Int# -> IO () -releaseLockByteOffAddr addr# i# = syncLockReleaseInt8AddrIO addr# i# +releaseLockByteOffAddr :: MonadPrim s m => Addr#-> Int# -> m () +releaseLockByteOffAddr addr# i# = unsafeIOToPrim $ syncLockReleaseInt8AddrIO addr# i# {-# INLINE releaseLockByteOffAddr #-} - withLockMutableByteArray :: - forall e b. Prim e + forall e a m. (Prim e, MonadUnliftPrim RW m) => MutableByteArray# RealWorld -> Int# - -> (Atom e -> IO (Atom e, b)) - -> IO b + -> (Atom e -> m (Atom e, a)) + -> m a withLockMutableByteArray mba# i# f = - let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) + let li0# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) + li# = 1# +# li0# in bracket_ - (unsafeUnmask (acquireLockByteOffMutableByteArray mba# li#)) - (releaseLockByteOffMutableByteArray mba# li#) $ - IO $ \s -> - case readMutableByteArray# mba# i# s of - (# s', a #) -> - case f a of - IO m -> - case m s' of - (# s'', (a', b) #) -> - (# writeMutableByteArray# mba# i# a' s'', b #) + (acquireLockByteOffMutableByteArray mba# li0#) + (releaseLockByteOffMutableByteArray mba# li0#) $ do + a <- prim (readByteOffMutableByteArray# mba# li#) + (Atom a', b) <- f (Atom a) + b <$ prim_ (writeByteOffMutableByteArray# mba# li# a') {-# INLINABLE withLockMutableByteArray #-} @@ -172,63 +180,65 @@ -- overwrite the contnts in the midst of reading, resulting in a value with contents -- from both values part before and part after the write. atomicReadAtomMutableByteArray :: - forall e. Prim e - => MutableByteArray# RealWorld + forall e m s. (Prim e, MonadPrim s m) + => MutableByteArray# s -> Int# - -> IO (Atom e) + -> m (Atom e) atomicReadAtomMutableByteArray mba# i# = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - in bracket_ - (unsafeUnmask (acquireLockByteOffMutableByteArray mba# li#)) - (releaseLockByteOffMutableByteArray mba# li#) - (coerce (IO (readByteOffMutableByteArray# mba# (1# +# li#)) :: IO e)) + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffMutableByteArray mba# li# + r :: e <- ST (readByteOffMutableByteArray# mba# (1# +# li#)) + coerce r <$ releaseLockByteOffMutableByteArray mba# li# {-# INLINABLE atomicReadAtomMutableByteArray #-} -- | Values are no longer guaranteed to be one word in size, as such in order for writes -- to be atomic we require locking. atomicWriteAtomMutableByteArray :: - forall e. Prim e - => MutableByteArray# RealWorld + forall e m s. (Prim e, MonadPrim s m) + => MutableByteArray# s -> Int# -> Atom e - -> IO () + -> m () atomicWriteAtomMutableByteArray mba# i# (Atom a) = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - in bracket_ - (unsafeUnmask (acquireLockByteOffMutableByteArray mba# li#)) - (releaseLockByteOffMutableByteArray mba# li#) - (prim_ (writeByteOffMutableByteArray# mba# (1# +# li#) a)) + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffMutableByteArray mba# li# + prim_ (writeByteOffMutableByteArray# mba# (1# +# li#) a) + releaseLockByteOffMutableByteArray mba# li# :: ST s () {-# INLINABLE atomicWriteAtomMutableByteArray #-} -- | Same as `atomicReadAtomMutableByteArray`, but for `Addr#` with offset atomicReadAtomOffAddr :: - forall e. Prim e + forall e m s. (Prim e, MonadPrim s m) => Addr# -> Int# - -> IO (Atom e) + -> m (Atom e) atomicReadAtomOffAddr mba# i# = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - in bracket_ - (unsafeUnmask (acquireLockByteOffAddr mba# li#)) - (releaseLockByteOffAddr mba# li#) - (coerce (IO (readOffAddr# mba# (1# +# li#)) :: IO e)) + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffAddr mba# li# + r :: e <- ST (readOffAddr# mba# (1# +# li#)) + coerce r <$ releaseLockByteOffAddr mba# li# {-# INLINABLE atomicReadAtomOffAddr #-} -- | Same as `atomicWriteAtomMutableByteArray`, but for `Addr#` with offset atomicWriteAtomOffAddr :: - forall e. Prim e + forall e m s. (Prim e, MonadPrim s m) => Addr# -> Int# -> Atom e - -> IO () -atomicWriteAtomOffAddr mba# i# (Atom a) = + -> m () +atomicWriteAtomOffAddr addr# i# (Atom a) = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - in bracket_ - (unsafeUnmask (acquireLockByteOffAddr mba# li#)) - (releaseLockByteOffAddr mba# li#) - (prim_ (writeOffAddr# mba# (1# +# li#) a)) + lockAddr# = addr# `plusAddr#` li# + valAddr# = lockAddr# `plusAddr#` 1# + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffAddr lockAddr# 0# + prim_ (writeOffAddr# valAddr# 0# a) + releaseLockByteOffAddr lockAddr# 0# :: ST s () {-# INLINABLE atomicWriteAtomOffAddr #-} @@ -241,61 +251,54 @@ -> IO b withLockOffAddr addr# i# f = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) + offAddr# = addr# `plusAddr#` (1# +# li#) in bracket_ - (unsafeUnmask (acquireLockByteOffAddr addr# li#)) - (releaseLockByteOffAddr addr# li#) $ - IO $ \s -> - case readOffAddr# addr# i# s of - (# s', a #) -> - case f a of - IO m -> - case m s' of - (# s'', (a', b) #) -> - (# writeOffAddr# addr# i# a' s'', b #) + (acquireLockByteOffAddr addr# li#) + (releaseLockByteOffAddr addr# li#) $ do + a <- prim (readOffAddr# offAddr# 0#) + (Atom a', b) <- f (Atom a) + b <$ prim_ (writeOffAddr# offAddr# 0# a') {-# INLINABLE withLockOffAddr #-} -atomicModifyAtomMutableByteArray# :: - forall e b s. Prim e + +atomicModifyAtomMutableByteArray :: + forall e a m s. (Prim e, MonadPrim s m) => MutableByteArray# s -> Int# - -> (Atom e -> (# Atom e, b #)) - -> State# s - -> (# State# s, b #) -atomicModifyAtomMutableByteArray# mba# i# f = + -> (Atom e -> (# Atom e, a #)) + -> m a +atomicModifyAtomMutableByteArray mba# i# f = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - mba'# = unsafeCoerce# mba# :: MutableByteArray# RealWorld - in unsafePrimBase $ - bracket_ - (unsafeUnmask (acquireLockByteOffMutableByteArray mba'# li#)) - (releaseLockByteOffMutableByteArray mba'# li#) $ - IO $ \s -> - case readMutableByteArray# mba'# i# s of - (# s', a #) -> - case f a of - (# a', b #) -> - (# writeMutableByteArray# mba'# i# a' s', b #) -{-# INLINE atomicModifyAtomMutableByteArray# #-} + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffMutableByteArray mba# li# + r <- ST $ \s -> + case readByteOffMutableByteArray# mba# (1# +# li#) s of + (# s', a #) -> + case f (Atom a) of + (# Atom a', b #) -> + (# writeByteOffMutableByteArray# mba# (1# +# li#) a' s', b #) + r <$ releaseLockByteOffMutableByteArray mba# li# +{-# INLINE atomicModifyAtomMutableByteArray #-} -atomicModifyAtomOffAddr# :: - forall e b s. Prim e +atomicModifyAtomOffAddr :: + forall e a m s. (Prim e, MonadPrim s m) => Addr# -> Int# - -> (Atom e -> (# Atom e, b #)) - -> State# s - -> (# State# s, b #) -atomicModifyAtomOffAddr# addr# i# f = + -> (Atom e -> (# Atom e, a #)) + -> m a +atomicModifyAtomOffAddr addr# i# f = let li# = i# *# sizeOf# (proxy# :: Proxy# (Atom e)) - in unsafePrimBase $ - bracket_ - (unsafeUnmask (acquireLockByteOffAddr addr# li#)) - (releaseLockByteOffAddr addr# li#) $ - IO $ \s -> - case readOffAddr# addr# i# s of - (# s', a #) -> - case f a of - (# a', b #) -> - (# writeOffAddr# addr# i# a' s', b #) -{-# INLINE atomicModifyAtomOffAddr# #-} + offAddr# = addr# `plusAddr#` (1# +# li#) + in uninterruptibleMaskPrimBase_ $ do + acquireLockByteOffAddr addr# li# + r <- ST $ \s -> + case readOffAddr# offAddr# 0# s of + (# s', a #) -> + case f (Atom a) of + (# Atom a', b #) -> + (# writeOffAddr# offAddr# 0# a' s', b #) + r <$ releaseLockByteOffAddr addr# li# +{-# INLINE atomicModifyAtomOffAddr #-} swapIfEqualVal :: Eq e => Atom e -> Atom e -> Atom e -> (# Atom e, Atom e #) @@ -312,30 +315,31 @@ instance (Eq a, Prim a) => Atomic (Atom a) where atomicReadMutableByteArray# mba# i# = - unsafePrimBase (atomicReadAtomMutableByteArray (unsafeCoerce# mba#) i#) + unST (atomicReadAtomMutableByteArray (unsafeCoerce# mba#) i#) {-# INLINABLE atomicReadMutableByteArray# #-} atomicWriteMutableByteArray# mba# i# a = - unsafePrimBase_ (atomicWriteAtomMutableByteArray (unsafeCoerce# mba#) i# a) + unST_ (atomicWriteAtomMutableByteArray (unsafeCoerce# mba#) i# a) {-# INLINABLE atomicWriteMutableByteArray# #-} - atomicReadOffAddr# addr# i# = unsafePrimBase (atomicReadAtomOffAddr addr# i#) + atomicReadOffAddr# addr# i# = unST (atomicReadAtomOffAddr addr# i#) {-# INLINABLE atomicReadOffAddr# #-} - atomicWriteOffAddr# addr# i# a = unsafePrimBase_ (atomicWriteAtomOffAddr addr# i# a) + atomicWriteOffAddr# addr# i# a = unST_ (atomicWriteAtomOffAddr addr# i# a) {-# INLINABLE atomicWriteOffAddr# #-} casMutableByteArray# mba# i# old new = - atomicModifyAtomMutableByteArray# mba# i# (swapIfEqualVal old new) + unST (atomicModifyAtomMutableByteArray mba# i# (swapIfEqualVal old new)) {-# INLINE casMutableByteArray# #-} casOffAddr# addr# i# old new = atomicModifyOffAddr# addr# i# (swapIfEqualVal old new) {-# INLINE casOffAddr# #-} casBoolMutableByteArray# mba# i# old new = - atomicModifyAtomMutableByteArray# mba# i# (swapIfEqualBool old new) + unST (atomicModifyAtomMutableByteArray mba# i# (swapIfEqualBool old new)) {-# INLINE casBoolMutableByteArray# #-} casBoolOffAddr# addr# i# old new = atomicModifyOffAddr# addr# i# (swapIfEqualBool old new) {-# INLINE casBoolOffAddr# #-} - atomicModifyMutableByteArray# = atomicModifyAtomMutableByteArray# + atomicModifyMutableByteArray# mba# i# f = + unST (atomicModifyAtomMutableByteArray mba# i# f) {-# INLINE atomicModifyMutableByteArray# #-} - atomicModifyOffAddr# = atomicModifyAtomOffAddr# + atomicModifyOffAddr# addr# i# f = unST (atomicModifyAtomOffAddr addr# i# f) {-# INLINE atomicModifyOffAddr# #-} diff --git a/src/Data/Prim/Class.hs b/src/Data/Prim/Class.hs --- a/src/Data/Prim/Class.hs +++ b/src/Data/Prim/Class.hs @@ -68,7 +68,6 @@ import Unsafe.Coerce #include "primal_compat.h" -import Data.Bits (Bits, FiniteBits) import Foreign.Storable (Storable) -- | Replacement for `Foreign.Ptr.IntPtr` with exported constructor. @@ -243,10 +242,10 @@ instance Prim () where type PrimBase () = () type SizeOf () = 0 - type Alignment () = 0 + type Alignment () = 1 sizeOf# _ = 0# {-# INLINE sizeOf# #-} - alignment# _ = 0# + alignment# _ = 1# {-# INLINE alignment# #-} indexByteOffByteArray# _ _ = () {-# INLINE indexByteOffByteArray# #-} @@ -985,9 +984,12 @@ toPrimBase (Arg a b) = (a, b) fromPrimBase (a, b) = Arg a b +#if __GLASGOW_HASKELL__ >= 800 instance Prim a => Prim (Const a b) where type PrimBase (Const a b) = a +#endif /* __GLASGOW_HASKELL__ >= 800 */ + #if __GLASGOW_HASKELL__ >= 802 instance a ~ b => Prim (a :~~: b) where @@ -1231,16 +1233,22 @@ instance Prim Fingerprint where type PrimBase Fingerprint = (Word64, Word64) + type Alignment Fingerprint = Alignment Word64 + alignment# _ = alignment# (proxy# :: Proxy# Word64) toPrimBase (Fingerprint a b) = (a, b) fromPrimBase (a, b) = Fingerprint a b instance Prim a => Prim (Ratio a) where type PrimBase (Ratio a) = (a, a) + type Alignment (Ratio a) = Alignment a + alignment# _ = alignment# (proxy# :: Proxy# a) toPrimBase (a :% b) = (a, b) fromPrimBase (a, b) = a :% b instance Prim a => Prim (Complex a) where type PrimBase (Complex a) = (a, a) + type Alignment (Complex a) = Alignment a + alignment# _ = alignment# (proxy# :: Proxy# a) toPrimBase (a :+ b) = (a, b) fromPrimBase (a, b) = a :+ b diff --git a/src/Data/Prim/Ref.hs b/src/Data/Prim/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Ref.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Data.Prim.Ref +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Ref + ( Ref(..) + , IORef + , STRef + -- * Create + , newRef + , newDeepRef + , isSameRef + -- * Read/write + , readRef + , swapRef + , swapDeepRef + , writeRef + , writeDeepRef + -- * Modify + -- ** Pure + , modifyRef + , modifyDeepRef + , modifyRef_ + , modifyFetchNewRef + , modifyFetchOldRef + -- ** Monadic + , modifyRefM + , modifyDeepRefM + , modifyRefM_ + , modifyFetchNewRefM + , modifyFetchOldRefM + -- * Atomic + , atomicReadRef + , atomicSwapRef + , atomicWriteRef + , atomicModifyRef + , atomicModifyRef_ + , atomicModifyFetchRef + , atomicModifyFetchNewRef + , atomicModifyFetchOldRef + , atomicModifyFetchBothRef + -- ** Original + , casRef + , atomicModifyRef2 + , atomicModifyRef2_ + , atomicModifyFetchNewRef2 + , atomicModifyFetchOldRef2 + , atomicModifyFetchBothRef2 + , atomicModifyFetchRef2 + -- * Lazy + -- It is recommended to refrain from usage of lazy functions because they are a memory + -- leak waiting to happen + , newLazyRef + , writeLazyRef + , swapLazyRef + , modifyLazyRef + , modifyLazyRefM + , atomicWriteLazyRef + , atomicModifyLazyRef + , atomicModifyFetchNewLazyRef + , atomicModifyFetchOldLazyRef + , atomicModifyFetchBothLazyRef + , atomicModifyFetchLazyRef + -- * Conversion + -- ** STRef + , toSTRef + , fromSTRef + -- ** IORef + , toIORef + , fromIORef + -- * Weak Pointer + , mkWeakRef + ) where + +import Control.DeepSeq +import Control.Prim.Monad +import Foreign.Prim +import Foreign.Prim.WeakPtr +import qualified GHC.IORef as IO +import qualified GHC.STRef as ST + +-- | Mutable variable that can hold any value. This is just like `Data.STRef.STRef`, but +-- with type arguments flipped and is generalized to work in `MonadPrim`. It only stores a +-- reference to the value which means it works on boxed values. If the type can be unboxed +-- with `Data.Prim.Class.Prim` class, consider using +-- [@PVar@](https://hackage.haskell.org/package/pvar) package instead. +-- +-- @since 0.3.0 +data Ref a s = Ref (MutVar# s a) + +-- | Uses `isSameRef` +instance Eq (Ref a s) where + (==) = isSameRef + +-- | Compatibility synonym +type IORef a = Ref a RW + +-- | Compatibility synonym +type STRef s a = Ref a s + +-- | Check whether supplied `Ref`s refer to the exact same one or not. +-- +-- @since 0.3.0 +isSameRef :: Ref a s -> Ref a s -> Bool +isSameRef (Ref ref1#) (Ref ref2#) = isTrue# (sameMutVar# ref1# ref2#) +{-# INLINE isSameRef #-} + + +-- | Create a new mutable variable. Initial value will be forced to WHNF (weak head normal form). +-- +-- ==== __Examples__ +-- +-- >>> import Debug.Trace +-- >>> import Data.Prim.Ref +-- >>> ref <- newRef (trace "Initial value is evaluated" (217 :: Int)) +-- Initial value is evaluated +-- >>> modifyFetchOldRef ref succ +-- 217 +-- >>> readRef ref +-- 218 +-- +-- @since 0.3.0 +newRef :: MonadPrim s m => a -> m (Ref a s) +newRef a = a `seq` newLazyRef a +{-# INLINE newRef #-} + + +-- | Create a new mutable variable. Same as `newRef`, but ensures that value is evaluated +-- to normal form. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.Trace +-- >>> import Data.Prim.Ref +-- >>> ref <- newDeepRef (Just (trace "Initial value is evaluated" (217 :: Int))) +-- Initial value is evaluated +-- >>> readRef ref +-- Just 217 +-- +-- @since 0.3.0 +newDeepRef :: (NFData a, MonadPrim s m) => a -> m (Ref a s) +newDeepRef a = a `deepseq` newLazyRef a +{-# INLINE newDeepRef #-} + +-- | Create a new mutable variable. Initial value stays unevaluated. +-- +-- ==== __Examples__ +-- +-- In below example you will see that initial value is never evaluated. +-- +-- >>> import Debug.Trace +-- >>> import Data.Prim.Ref +-- >>> ref <- newLazyRef (trace "Initial value is evaluated" (undefined :: Int)) +-- >>> writeRef ref 1024 +-- >>> modifyFetchNewRef ref succ +-- 1025 +-- +-- @since 0.3.0 +newLazyRef :: MonadPrim s m => a -> m (Ref a s) +newLazyRef a = + prim $ \s -> + case newMutVar# a s of + (# s', ref# #) -> (# s', Ref ref# #) +{-# INLINE newLazyRef #-} + +---------------- +-- Read/Write -- +---------------- + +-- | Read contents of the mutable variable +-- +-- ==== __Examples__ +-- +-- >>> import Data.Prim.Ref +-- >>> ref <- newRef "Hello World!" +-- >>> readRef ref +-- "Hello World!" +-- +-- @since 0.3.0 +readRef :: MonadPrim s m => Ref a s -> m a +readRef (Ref ref#) = prim (readMutVar# ref#) +{-# INLINE readRef #-} + + +-- | Swap a value of a mutable variable with a new one, while retrieving the old one. New +-- value is evaluated prior to it being written to the variable. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef (Left "Initial" :: Either String String) +-- >>> swapRef ref (Right "Last") +-- Left "Initial" +-- >>> readRef ref +-- Right "Last" +-- +-- @since 0.3.0 +swapRef :: MonadPrim s m => Ref a s -> a -> m a +swapRef ref a = readRef ref <* writeRef ref a +{-# INLINE swapRef #-} + + +-- | Swap a value of a mutable variable with a new one lazily, while retrieving the old +-- one. New value is __not__ evaluated prior to it being written to the variable. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef "Initial" +-- >>> swapLazyRef ref undefined +-- "Initial" +-- >>> _ <- swapLazyRef ref "Different" +-- >>> readRef ref +-- "Different" +-- +-- @since 0.3.0 +swapLazyRef :: MonadPrim s m => Ref a s -> a -> m a +swapLazyRef ref a = readRef ref <* writeLazyRef ref a +{-# INLINE swapLazyRef #-} + + +-- | Swap a value of a mutable variable with a new one, while retrieving the old one. New +-- value is evaluated to __normal__ form prior to it being written to the variable. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef (Just "Initial") +-- >>> swapDeepRef ref (Just (errorWithoutStackTrace "foo")) +-- *** Exception: foo +-- >>> readRef ref +-- Just "Initial" +-- +-- @since 0.3.0 +swapDeepRef :: (NFData a, MonadPrim s m) => Ref a s -> a -> m a +swapDeepRef ref a = readRef ref <* writeDeepRef ref a +{-# INLINE swapDeepRef #-} + + +-- | Write a value into a mutable variable strictly. If evaluating a value results in +-- exception, original value in the mutable variable will not be affected. Another great +-- benfit of this over `writeLazyRef` is that it helps avoiding memory leaks. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef "Original value" +-- >>> import Control.Prim.Exception +-- >>> _ <- try $ writeRef ref undefined :: IO (Either SomeException ()) +-- >>> readRef ref +-- "Original value" +-- >>> writeRef ref "New total value" +-- >>> readRef ref +-- "New total value" +-- +-- @since 0.3.0 +writeRef :: MonadPrim s m => Ref a s -> a -> m () +writeRef ref !a = writeLazyRef ref a +{-# INLINE writeRef #-} + + +-- | Same as `writeRef`, but will evaluate the argument to Normal Form prior to writing it +-- to the `Ref` +-- +-- @since 0.3.0 +writeDeepRef :: (NFData a, MonadPrim s m) => Ref a s -> a -> m () +writeDeepRef ref a = a `deepseq` writeLazyRef ref a +{-# INLINE writeDeepRef #-} + +-- | Write a value into a mutable variable lazily. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef "Original value" +-- >>> import Debug.Trace +-- >>> writeLazyRef ref (trace "'New string' is evaluated" "New string") +-- >>> x <- readRef ref +-- >>> writeRef ref (trace "'Totally new string' is evaluated" "Totally new string") +-- 'Totally new string' is evaluated +-- >>> putStrLn x +-- 'New string' is evaluated +-- New string +-- +-- @since 0.3.0 +writeLazyRef :: MonadPrim s m => Ref a s -> a -> m () +writeLazyRef (Ref ref#) a = prim_ (writeMutVar# ref# a) +{-# INLINE writeLazyRef #-} + + +------------ +-- Modify -- +------------ + + +-- | Apply a pure function to the contents of a mutable variable strictly. Returns the +-- artifact produced by the modifying function. Artifact is not forced, therfore it cannot +-- affect the outcome of modification. This function is a faster alternative to +-- `atomicModifyRef`, except without any guarantees of atomicity and ordering of mutable +-- operations during concurrent modification of the same `Ref`. For lazy version see +-- `modifyLazyRef` and for strict evaluation to normal form see `modifyDeepRef`. +-- +-- @since 0.3.0 +modifyRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +modifyRef ref f = modifyRefM ref (pure . f) +{-# INLINE modifyRef #-} + +-- | Same as `modifyRef`, except it will evaluate result of computation to normal form. +-- +-- @since 0.3.0 +modifyDeepRef :: (NFData a, MonadPrim s m) => Ref a s -> (a -> (a, b)) -> m b +modifyDeepRef ref f = modifyDeepRefM ref (pure . f) +{-# INLINE modifyDeepRef #-} + +-- | Apply a pure function to the contents of a mutable variable strictly. +-- +-- @since 0.3.0 +modifyRef_ :: MonadPrim s m => Ref a s -> (a -> a) -> m () +modifyRef_ ref f = modifyRefM_ ref (pure . f) +{-# INLINE modifyRef_ #-} + +-- | Apply a pure function to the contents of a mutable variable strictly. Returns the new value. +-- +-- @since 0.3.0 +modifyFetchNewRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +modifyFetchNewRef ref f = modifyFetchNewRefM ref (pure . f) +{-# INLINE modifyFetchNewRef #-} + +-- | Apply a pure function to the contents of a mutable variable strictly. Returns the old value. +-- +-- ==== __Examples__ +-- +-- >>> ref1 <- newRef (10 :: Int) +-- >>> ref2 <- newRef (201 :: Int) +-- >>> modifyRefM_ ref1 (\x -> modifyFetchOldRef ref2 (* x)) +-- >>> readRef ref1 +-- 201 +-- >>> readRef ref2 +-- 2010 +-- +-- @since 0.3.0 +modifyFetchOldRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +modifyFetchOldRef ref f = modifyFetchOldRefM ref (pure . f) +{-# INLINE modifyFetchOldRef #-} + + +-- | Apply a pure function to the contents of a mutable variable lazily. Returns the +-- artifact produced by the modifying function. +-- +-- @since 0.3.0 +modifyLazyRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +modifyLazyRef ref f = modifyLazyRefM ref (pure . f) +{-# INLINE modifyLazyRef #-} + + + +-- | Modify value of a mutable variable with a monadic action. It is not strict in a +-- return value of type @b@, but the ne value written into the mutable variable is +-- evaluated to WHNF. +-- +-- ==== __Examples__ +-- +modifyRefM :: MonadPrim s m => Ref a s -> (a -> m (a, b)) -> m b +modifyRefM ref f = do + (a', b) <- f =<< readRef ref + b <$ writeRef ref a' +{-# INLINE modifyRefM #-} + + +-- | Same as `modifyRefM`, except evaluates new value to normal form prior ot it being +-- written to the mutable ref. +modifyDeepRefM :: (NFData a, MonadPrim s m) => Ref a s -> (a -> m (a, b)) -> m b +modifyDeepRefM ref f = do + (a', b) <- f =<< readRef ref + b <$ writeDeepRef ref a' +{-# INLINE modifyDeepRefM #-} + + +-- | Modify value of a mutable variable with a monadic action. Result is written strictly. +-- +-- ==== __Examples__ +-- +-- >>> ref <- newRef (Just "Some value") +-- >>> modifyRefM_ ref $ \ mv -> Nothing <$ mapM_ putStrLn mv +-- Some value +-- >>> readRef ref +-- Nothing +-- +-- @since 0.3.0 +modifyRefM_ :: MonadPrim s m => Ref a s -> (a -> m a) -> m () +modifyRefM_ ref f = readRef ref >>= f >>= writeRef ref +{-# INLINE modifyRefM_ #-} + +-- | Apply a monadic action to the contents of a mutable variable strictly. Returns the old value. +-- +-- ==== __Examples__ +-- +-- >>> refName <- newRef "My name is: " +-- >>> refMyName <- newRef "Alexey" +-- >>> myName <- modifyFetchOldRefM refMyName $ \ name -> "Leo" <$ modifyRef_ refName (++ name) +-- >>> readRef refName >>= putStrLn +-- My name is: Alexey +-- >>> putStrLn myName +-- Alexey +-- >>> readRef refMyName >>= putStrLn +-- Leo +-- +-- @since 0.3.0 +modifyFetchOldRefM :: MonadPrim s m => Ref a s -> (a -> m a) -> m a +modifyFetchOldRefM ref f = do + a <- readRef ref + a <$ (writeRef ref =<< f a) +{-# INLINE modifyFetchOldRefM #-} + + +-- | Apply a monadic action to the contents of a mutable variable strictly. Returns the new value. +-- +-- @since 0.3.0 +modifyFetchNewRefM :: MonadPrim s m => Ref a s -> (a -> m a) -> m a +modifyFetchNewRefM ref f = do + a <- readRef ref + a' <- f a + a' <$ writeRef ref a' +{-# INLINE modifyFetchNewRefM #-} + +-- | Same as `modifyRefM`, but do not evaluate the new value written into the `Ref`. +-- +-- @since 0.3.0 +modifyLazyRefM :: MonadPrim s m => Ref a s -> (a -> m (a, b)) -> m b +modifyLazyRefM ref f = do + a <- readRef ref + (a', b) <- f a + b <$ writeLazyRef ref a' +{-# INLINE modifyLazyRefM #-} + +------------ +-- Atomic -- +------------ + + +-- | Evaluate a value and write it atomically into a `Ref`. This is different from +-- `writeRef` because [a memory barrier](https://en.wikipedia.org/wiki/Memory_barrier) +-- will be issued. Use this instead of `writeRef` in order to guarantee the ordering of +-- operations in a concurrent environment. +-- +-- @since 0.3.0 +atomicWriteRef :: MonadPrim s m => Ref e s -> e -> m () +atomicWriteRef ref !x = atomicModifyRef_ ref (const x) +{-# INLINE atomicWriteRef #-} + +-- | This will behave exactly the same as `readRef` when the `Ref` is accessed within a +-- single thread only. However, despite being slower, it can help with with restricting +-- order of operations in cases when multiple threads perform modifications to the `Ref` +-- because it implies a memory barrier. +-- +-- @since 0.3.0 +atomicReadRef :: MonadPrim s m => Ref e s -> m e +atomicReadRef ref = atomicModifyFetchOldRef ref id + +-- | Same as `atomicWriteRef`, but also returns the old value. +-- +-- @since 0.3.0 +atomicSwapRef :: MonadPrim s m => Ref e s -> e -> m e +atomicSwapRef ref x = atomicModifyFetchOldRef ref (const x) +{-# INLINE atomicSwapRef #-} + +numTriesCAS :: Int +numTriesCAS = 35 + +-- | Apply a function to the value stored in a mutable `Ref` atomically. Function is +-- applied strictly with respect to the newly returned value, which matches the semantics +-- of `atomicModifyIORef'`, however the difference is that the artifact returned by the +-- action is not evaluated. +-- +-- ====__Example__ +-- +-- >>> +-- +-- @since 0.3.0 +atomicModifyRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +atomicModifyRef ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + case f old of + (!new, result) -> do + (success, current) <- casRef ref old new + if success + then pure result + else loop (i + 1) current + | otherwise = atomicModifyRef2 ref f +{-# INLINE atomicModifyRef #-} + + + +atomicModifyRef2 :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +atomicModifyRef2 (Ref ref#) f = +#if __GLASGOW_HASKELL__ <= 806 + let g prev = + case f prev of + r@(!_new, _result) -> r + in prim (atomicModifyMutVar# ref# g) +#else + prim $ \s -> + case atomicModifyMutVar2# ref# f s of + (# s', _old, (!_new, result) #) -> (# s', result #) +#endif +{-# INLINE atomicModifyRef2 #-} + + +atomicModifyRef_ :: MonadPrim s m => Ref a s -> (a -> a) -> m () +atomicModifyRef_ ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + (success, current) <- casRef ref old $! f old + unless success $ loop (i + 1) current + | otherwise = atomicModifyRef2_ ref f +{-# INLINE atomicModifyRef_ #-} + +atomicModifyRef2_ :: MonadPrim s m => Ref a s -> (a -> a) -> m () +atomicModifyRef2_ (Ref ref#) f = + prim_ $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', _prev, !_cur #) -> s' +{-# INLINE atomicModifyRef2_ #-} + +atomicModifyFetchOldRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchOldRef ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + (success, current) <- casRef ref old $! f old + if success + then pure old + else loop (i + 1) current + | otherwise = atomicModifyFetchOldRef2 ref f +{-# INLINE atomicModifyFetchNewRef #-} + +atomicModifyFetchOldRef2 :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchOldRef2 (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', _prev, !_cur #) -> (# s', _prev #) +{-# INLINE atomicModifyFetchOldRef2 #-} + + +atomicModifyFetchNewRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchNewRef ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + (success, current) <- casRef ref old $! f old + if success + then pure current + else loop (i + 1) current + | otherwise = atomicModifyFetchNewRef2 ref f +{-# INLINE atomicModifyFetchOldRef #-} + +atomicModifyFetchNewRef2 :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchNewRef2 (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', _prev, !cur #) -> (# s', cur #) +{-# INLINE atomicModifyFetchNewRef2 #-} + + + +atomicModifyFetchBothRef :: MonadPrim s m => Ref a s -> (a -> a) -> m (a, a) +atomicModifyFetchBothRef ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + (success, current) <- casRef ref old $! f old + if success + then pure (old, current) + else loop (i + 1) current + | otherwise = atomicModifyFetchBothRef2 ref f +{-# INLINE atomicModifyFetchBothRef #-} + + +atomicModifyFetchBothRef2 :: MonadPrim s m => Ref a s -> (a -> a) -> m (a, a) +atomicModifyFetchBothRef2 (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', prev, !cur #) -> (# s', (prev, cur) #) +{-# INLINE atomicModifyFetchBothRef2 #-} + +-- | Appy a function to the value in mutable `Ref` atomically +-- +-- @since 0.3.0 +atomicModifyFetchRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m (a, a, b) +atomicModifyFetchRef ref f = readRef ref >>= loop (0 :: Int) + where + loop i old + | i < numTriesCAS = do + case f old of + (!new, result) -> do + (success, current) <- casRef ref old new + if success + then pure (old, new, result) + else loop (i + 1) current + | otherwise = atomicModifyFetchRef2 ref f +{-# INLINE atomicModifyFetchRef #-} + + +-- TODO: Test this property +-- @atomicModifyIORef' ref (\x -> (x+1, undefined))@ +-- +-- will increment the 'IORef' and then throw an exception in the calling +-- thread. + +atomicModifyFetchRef2 :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m (a, a, b) +atomicModifyFetchRef2 ref f = + atomicModifyFetchLazyRef ref $ \current -> + case f current of + r@(!_new, _res) -> r +{-# INLINE atomicModifyFetchRef2 #-} + + +-- atomicModifyRef2 :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m (a, a, b) +-- (Ref ref#) f = +-- let g a = +-- case f a of +-- t@(a', _) -> a' `seq` t +-- in prim $ \s -> +-- case atomicModifyMutVar2# ref# g s of +-- (# s', old, (new, b) #) -> +-- case seq# new s' of +-- (# s'', new' #) -> +-- case seq# b s'' of +-- (# s''', b' #) -> (# s''', (old, new', b') #) + +-- atomicModifyRef2 :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +-- atomicModifyRef2 (Ref ref#) f = +-- prim $ \s -> +-- case atomicModifyMutVar2# ref# f s of +-- (# s', _old, res #) -> (# s', res #) +-- {-# INLINE atomicModifyRef2 #-} + + + + + + +atomicModifyFetchBothLazyRef :: MonadPrim s m => Ref a s -> (a -> a) -> m (a, a) +atomicModifyFetchBothLazyRef (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', prev, cur #) -> (# s', (prev, cur) #) +{-# INLINE atomicModifyFetchBothLazyRef #-} + + +casRef :: MonadPrim s m => Ref a s -> a -> a -> m (Bool, a) +casRef (Ref ref#) expOld new = + prim $ \s -> + case casMutVar# ref# expOld new s of + (# s', failed#, actualOld #) -> + (# s', (isTrue# (failed# ==# 0#), actualOld) #) +{-# INLINE casRef #-} + +atomicModifyFetchLazyRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m (a, a, b) +atomicModifyFetchLazyRef (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar2# ref# f s of + (# s', old, ~(new, res) #) -> (# s', (old, new, res) #) +{-# INLINE atomicModifyFetchLazyRef #-} + + +atomicModifyLazyRef :: MonadPrim s m => Ref a s -> (a -> (a, b)) -> m b +atomicModifyLazyRef (Ref ref#) f = prim (atomicModifyMutVar# ref# f) +{-# INLINE atomicModifyLazyRef #-} + +atomicModifyLazyRef_ :: MonadPrim s m => Ref a s -> (a -> a) -> m () +atomicModifyLazyRef_ (Ref ref#) f = + prim_ $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', _prev, _cur #) -> s' +{-# INLINE atomicModifyLazyRef_ #-} + +atomicModifyFetchOldLazyRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchOldLazyRef (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', prev, _cur #) -> (# s', prev #) + +atomicModifyFetchNewLazyRef :: MonadPrim s m => Ref a s -> (a -> a) -> m a +atomicModifyFetchNewLazyRef (Ref ref#) f = + prim $ \s -> + case atomicModifyMutVar_# ref# f s of + (# s', _prev, cur #) -> (# s', cur #) + +atomicWriteLazyRef :: MonadPrim s m => Ref b s -> b -> m () +atomicWriteLazyRef ref x = atomicModifyLazyRef_ ref (const x) + + +-- | Convert `Ref` to `STRef` +-- +-- @since 0.3.0 +toSTRef :: Ref a s -> ST.STRef s a +toSTRef (Ref ref#) = ST.STRef ref# +{-# INLINE toSTRef #-} + +-- | Convert `STRef` to `Ref` +-- +-- @since 0.3.0 +fromSTRef :: ST.STRef s a -> Ref a s +fromSTRef (ST.STRef ref#) = Ref ref# +{-# INLINE fromSTRef #-} + +-- | Convert `Ref` to `IORef` +-- +-- @since 0.3.0 +toIORef :: Ref a RW -> IO.IORef a +toIORef = coerce . toSTRef +{-# INLINE toIORef #-} + +-- | Convert `IORef` to `Ref` +-- +-- @since 0.3.0 +fromIORef :: IO.IORef a -> Ref a RW +fromIORef = fromSTRef . coerce +{-# INLINE fromIORef #-} + + + + +-- | Create a `Weak` pointer associated with the supplied `Ref`. +-- +-- Same as `Data.IORef.mkWeakRef` from @base@, but works in any `MonadPrim` with +-- `RealWorld` state token. +-- +-- @since 0.3.0 +mkWeakRef :: + forall a b m. MonadUnliftPrim RW m + => Ref a RW + -> m b -- ^ An action that will get executed whenever `Ref` gets garbage collected by + -- the runtime. + -> m (Weak (Ref a RW)) +mkWeakRef ref@(Ref ref#) !finalizer = + runInPrimBase finalizer $ \f# s -> + case mkWeak# ref# ref f# s of + (# s', weak# #) -> (# s', Weak weak# #) +{-# INLINE mkWeakRef #-} + + + +-- atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +-- -- See Note [atomicModifyIORef' definition] +-- atomicModifyIORef' ref f = do +-- (_old, (_new, !res)) <- atomicModifyIORef2 ref $ +-- \old -> case f old of +-- r@(!_new, _res) -> r +-- pure res +-- atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +-- atomicModifyIORef' (IORef (STRef r#)) f = +-- IO +-- (\s -> +-- case atomicModifyMutVar2# r# f s of +-- (# s', old, res@(!_new, _) #) -> (# s', (old, res) #)) + +-- atomicModifyIORef2 :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +-- atomicModifyIORef2 ref f = do +-- r@(_old, (_new, _res)) <- atomicModifyIORef2Lazy ref f +-- return r + +-- atomicModifyIORef2Lazy :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +-- atomicModifyIORef2Lazy (IORef (STRef r#)) f = +-- IO (\s -> case atomicModifyMutVar2# r# f s of +-- (# s', old, res #) -> (# s', (old, res) #)) + + diff --git a/src/Foreign/Prim.hs b/src/Foreign/Prim.hs --- a/src/Foreign/Prim.hs +++ b/src/Foreign/Prim.hs @@ -16,10 +16,19 @@ , unsafeThawArrayArray# , unInt# , unWord# + , touch# + , keepAlive# -- * Primitive , module Foreign.Prim.C , module Foreign.Prim.Cmm -- * Re-exports + , RW + , IO(..) + , unIO + , unIO_ + , ST(..) + , unST + , unST_ , module Foreign.C.Types , module System.Posix.Types , module GHC.Exts @@ -30,13 +39,17 @@ , module GHC.Word ) where +import Control.Prim.Eval +import Control.Prim.Monad.Internal import Foreign.Prim.C import Foreign.Prim.Cmm import Foreign.C.Types import System.Posix.Types -import GHC.Exts +import GHC.Exts hiding (touch#) import GHC.Int import GHC.Word +import GHC.IO +import GHC.ST #if __GLASGOW_HASKELL__ < 804 import GHC.Prim ( addCFinalizerToWeak# @@ -46,6 +59,7 @@ , mkWeakNoFinalizer# ) #endif + unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutableByteArray# s #) unsafeThawByteArray# ba# s = (# s, unsafeCoerce# ba# #) diff --git a/src/Foreign/Prim/C/LtGHC806.hs b/src/Foreign/Prim/C/LtGHC806.hs --- a/src/Foreign/Prim/C/LtGHC806.hs +++ b/src/Foreign/Prim/C/LtGHC806.hs @@ -109,12 +109,15 @@ indexWord8ArrayAsChar# :: ByteArray# -> Int# -> Char# indexWord8ArrayAsChar# = indexCharArray# +{-# INLINE indexWord8ArrayAsChar# #-} readWord8ArrayAsChar# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Char# #) readWord8ArrayAsChar# = readCharArray# +{-# INLINE readWord8ArrayAsChar# #-} writeWord8ArrayAsChar# :: MutableByteArray# d -> Int# -> Char# -> State# d -> State# d writeWord8ArrayAsChar# = writeCharArray# +{-# INLINE writeWord8ArrayAsChar# #-} foreign import ccall unsafe "primal_compat.c primal_memread32" indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char# @@ -126,12 +129,14 @@ readWord8ArrayAsWideChar# mb# i# s = case unsafePrimBase (readWord8ArrayAsWideCharIO# mb# i#) s of (# s', C# c# #) -> (# s', c# #) +{-# INLINE readWord8ArrayAsWideChar# #-} foreign import ccall unsafe "primal_compat.c primal_memwrite32" writeWord8ArrayAsWideCharIO# :: MutableByteArray# d -> Int# -> Char# -> IO () writeWord8ArrayAsWideChar# :: MutableByteArray# d -> Int# -> Char# -> State# d -> State# d writeWord8ArrayAsWideChar# mb# i# c# = unsafePrimBase_ (writeWord8ArrayAsWideCharIO# mb# i# c#) +{-# INLINE writeWord8ArrayAsWideChar# #-} -- Addr# @@ -163,9 +168,11 @@ readWord8ArrayAsAddr# mb# i# s = case unsafePrimBase (readWord8ArrayAsPtrIO# mb# i#) s of (# s', Ptr addr# #) -> (# s', addr# #) +{-# INLINE readWord8ArrayAsAddr# #-} writeWord8ArrayAsAddr# :: MutableByteArray# d -> Int# -> Addr# -> State# d -> State# d writeWord8ArrayAsAddr# mb# i# addr# = unsafePrimBase_ (writeWord8ArrayAsAddrIO# mb# i# addr#) +{-# INLINE writeWord8ArrayAsAddr# #-} -- StablePtr# @@ -195,54 +202,65 @@ readWord8ArrayAsStablePtr# mb# i# s = case unsafePrimBase (readWord8ArrayAsStablePtrIO# mb# i#) s of (# s', StablePtr addr# #) -> (# s', addr# #) +{-# INLINE readWord8ArrayAsStablePtr# #-} writeWord8ArrayAsStablePtr# :: MutableByteArray# d -> Int# -> StablePtr# a -> State# d -> State# d writeWord8ArrayAsStablePtr# mb# i# addr# = unsafePrimBase_ (writeWord8ArrayAsStablePtrIO# mb# i# addr#) +{-# INLINE writeWord8ArrayAsStablePtr# #-} -- Float# -foreign import ccall unsafe "primal_compat.c primal_memread32" +foreign import ccall unsafe "primal_compat.c primal_memread_float" indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float# -foreign import ccall unsafe "primal_compat.c primal_memread32" +foreign import ccall unsafe "primal_compat.c primal_memread_float" readWord8ArrayAsFloatIO# :: MutableByteArray# d -> Int# -> IO Float readWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Float# #) readWord8ArrayAsFloat# mb# i# s = case unsafePrimBase (readWord8ArrayAsFloatIO# mb# i#) s of (# s', F# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsFloat# #-} -foreign import ccall unsafe "primal_compat.c primal_memwrite32" - writeWord8ArrayAsFloatIO# :: MutableByteArray# d -> Int# -> Float# -> IO () +foreign import ccall unsafe "primal_compat.c primal_memwrite_float" + writeWord8ArrayAsFloatIO# :: MutableByteArray# d -> Int# -> Float -> IO () writeWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> Float# -> State# d -> State# d -writeWord8ArrayAsFloat# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsFloatIO# mb# i# a#) +writeWord8ArrayAsFloat# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsFloatIO# mb# i# (F# a#)) +{-# INLINE writeWord8ArrayAsFloat# #-} -- Double# -foreign import ccall unsafe "primal_compat.c primal_memread64" +foreign import ccall unsafe "primal_compat.c primal_memread_double" indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double# -foreign import ccall unsafe "primal_compat.c primal_memread64" +foreign import ccall unsafe "primal_compat.c primal_memread_double" readWord8ArrayAsDoubleIO# :: MutableByteArray# d -> Int# -> IO Double readWord8ArrayAsDouble# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Double# #) readWord8ArrayAsDouble# mb# i# s = case unsafePrimBase (readWord8ArrayAsDoubleIO# mb# i#) s of (# s', D# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsDouble# #-} -foreign import ccall unsafe "primal_compat.c primal_memwrite64" +foreign import ccall unsafe "primal_compat.c primal_memwrite_double" writeWord8ArrayAsDoubleIO# :: MutableByteArray# d -> Int# -> Double# -> IO () writeWord8ArrayAsDouble# :: MutableByteArray# d -> Int# -> Double# -> State# d -> State# d writeWord8ArrayAsDouble# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsDoubleIO# mb# i# a#) +{-# INLINE writeWord8ArrayAsDouble# #-} -- Int16# foreign import ccall unsafe "primal_compat.c primal_memread16" - indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int# + indexWord8ArrayAsInt16 :: ByteArray# -> Int# -> Int16 +indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt16# ba i = case indexWord8ArrayAsInt16 ba i of + I16# a# -> a# +{-# INLINE indexWord8ArrayAsInt16# #-} + foreign import ccall unsafe "primal_compat.c primal_memread16" readWord8ArrayAsInt16IO# :: MutableByteArray# d -> Int# -> IO Int16 @@ -250,19 +268,27 @@ readWord8ArrayAsInt16# mb# i# s = case unsafePrimBase (readWord8ArrayAsInt16IO# mb# i#) s of (# s', I16# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsInt16# #-} foreign import ccall unsafe "primal_compat.c primal_memwrite16" - writeWord8ArrayAsInt16IO# :: MutableByteArray# d -> Int# -> Int# -> IO () + writeWord8ArrayAsInt16IO# :: MutableByteArray# d -> Int# -> Int16 -> IO () writeWord8ArrayAsInt16# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d -writeWord8ArrayAsInt16# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsInt16IO# mb# i# a#) +writeWord8ArrayAsInt16# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsInt16IO# mb# i# (I16# a#)) +{-# INLINE writeWord8ArrayAsInt16# #-} -- Int32# foreign import ccall unsafe "primal_compat.c primal_memread32" - indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int# + indexWord8ArrayAsInt32 :: ByteArray# -> Int# -> Int32 +indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt32# ba i = case indexWord8ArrayAsInt32 ba i of + I32# a# -> a# +{-# INLINE indexWord8ArrayAsInt32# #-} + + foreign import ccall unsafe "primal_compat.c primal_memread32" readWord8ArrayAsInt32IO# :: MutableByteArray# d -> Int# -> IO Int32 @@ -270,12 +296,14 @@ readWord8ArrayAsInt32# mb# i# s = case unsafePrimBase (readWord8ArrayAsInt32IO# mb# i#) s of (# s', I32# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsInt32# #-} foreign import ccall unsafe "primal_compat.c primal_memwrite32" - writeWord8ArrayAsInt32IO# :: MutableByteArray# d -> Int# -> Int# -> IO () + writeWord8ArrayAsInt32IO# :: MutableByteArray# d -> Int# -> Int32 -> IO () writeWord8ArrayAsInt32# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d -writeWord8ArrayAsInt32# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsInt32IO# mb# i# a#) +writeWord8ArrayAsInt32# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsInt32IO# mb# i# (I32# a#)) +{-# INLINE writeWord8ArrayAsInt32# #-} -- Int64# @@ -305,7 +333,10 @@ readWord8ArrayAsInt64# mb# i# s = case unsafePrimBase (readWord8ArrayAsInt64IO# mb# i#) s of (# s', I64# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsInt64# #-} + writeWord8ArrayAsInt64# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsInt64IO# mb# i# a#) +{-# INLINE writeWord8ArrayAsInt64# #-} -- Int# @@ -333,9 +364,11 @@ readWord8ArrayAsInt# mb# i# s = case unsafePrimBase (readWord8ArrayAsIntIO# mb# i#) s of (# s', I# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsInt# #-} writeWord8ArrayAsInt# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d writeWord8ArrayAsInt# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsIntIO# mb# i# a#) +{-# INLINE writeWord8ArrayAsInt# #-} -- Word16# @@ -349,13 +382,14 @@ readWord8ArrayAsWord16# mb# i# s = case unsafePrimBase (readWord8ArrayAsWord16IO# mb# i#) s of (# s', W16# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsWord16# #-} foreign import ccall unsafe "primal_compat.c primal_memwrite16" writeWord8ArrayAsWord16IO# :: MutableByteArray# d -> Int# -> Word# -> IO () writeWord8ArrayAsWord16# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d writeWord8ArrayAsWord16# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsWord16IO# mb# i# a#) - +{-# INLINE writeWord8ArrayAsWord16# #-} -- Word32# @@ -369,12 +403,14 @@ readWord8ArrayAsWord32# mb# i# s = case unsafePrimBase (readWord8ArrayAsWord32IO# mb# i#) s of (# s', W32# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsWord32# #-} foreign import ccall unsafe "primal_compat.c primal_memwrite32" writeWord8ArrayAsWord32IO# :: MutableByteArray# d -> Int# -> Word# -> IO () writeWord8ArrayAsWord32# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d writeWord8ArrayAsWord32# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsWord32IO# mb# i# a#) +{-# INLINE writeWord8ArrayAsWord32# #-} -- Word64# @@ -404,7 +440,9 @@ readWord8ArrayAsWord64# mb# i# s = case unsafePrimBase (readWord8ArrayAsWord64IO# mb# i#) s of (# s', W64# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsWord64# #-} writeWord8ArrayAsWord64# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsWord64IO# mb# i# a#) +{-# INLINE writeWord8ArrayAsWord64# #-} -- Word# @@ -432,8 +470,10 @@ readWord8ArrayAsWord# mb# i# s = case unsafePrimBase (readWord8ArrayAsWordIO# mb# i#) s of (# s', W# a# #) -> (# s', a# #) +{-# INLINE readWord8ArrayAsWord# #-} writeWord8ArrayAsWord# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d writeWord8ArrayAsWord# mb# i# a# = unsafePrimBase_ (writeWord8ArrayAsWordIO# mb# i# a#) +{-# INLINE writeWord8ArrayAsWord# #-} #endif /* __GLASGOW_HASKELL__ < 806 */ diff --git a/src/Foreign/Prim/Cmm.hs b/src/Foreign/Prim/Cmm.hs --- a/src/Foreign/Prim/Cmm.hs +++ b/src/Foreign/Prim/Cmm.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE UnboxedTuples #-} -- | -- Module : Foreign.Prim.Cmm -- Copyright : (c) Alexey Kuleshevich 2020 @@ -16,6 +17,14 @@ , floatToWord32# , word64ToDouble# , doubleToWord64# + , getSizeofMutableArray# + , shrinkMutableArray# + , resizeMutableArray# +#if __GLASGOW_HASKELL__ < 810 + , getSizeofSmallMutableArray# + , shrinkSmallMutableArray# + , resizeSmallMutableArray# +#endif ) where @@ -45,4 +54,83 @@ doubleToWord64# :: Double# -> Word# #else doubleToWord64# :: Double# -> Word64# +#endif + + + +getSizeofMutableArray# :: MutableArray# s a -> State# s -> (# State# s, Int# #) +getSizeofMutableArray# sma# s# = (# s#, sizeofMutableArray# sma# #) +{-# INLINE getSizeofMutableArray# #-} + + +-- | Shrink MutableArray# +foreign import prim "primal_stg_shrinkMutableArrayzh" + shrinkMutableArrayCmm# :: MutableArray# s a -> Int# -> State# s -> (# State# s, Int# #) + +shrinkMutableArray# :: MutableArray# s a -> Int# -> State# s -> State# s +shrinkMutableArray# ma# i# s = + case shrinkMutableArrayCmm# ma# i# s of + (# s', _ #) -> s' +{-# INLINE shrinkMutableArray# #-} + +resizeMutableArray# :: + MutableArray# s a -- ^ Array to resize + -> Int# -- ^ New size of array + -> a -- ^ Newly created slots initialized to this element. Only used when array is + -- grown. + -> State# s + -> (# State# s, MutableArray# s a #) +resizeMutableArray# arr0 szNew a s0 = + case getSizeofMutableArray# arr0 s0 of + (# s1, szOld #) -> + if isTrue# (szNew <# szOld) + then case shrinkMutableArrayCmm# arr0 szNew s1 of + (# s2, _ #) -> (# s2, arr0 #) + else if isTrue# (szNew ># szOld) + then case newArray# szNew a s1 of + (# s2, arr1 #) -> + case copyMutableArray# arr0 0# arr1 0# szOld s2 of + s3 -> (# s3, arr1 #) + else (# s1, arr0 #) +{-# INLINE resizeMutableArray# #-} + + +#if __GLASGOW_HASKELL__ < 810 + +getSizeofSmallMutableArray# :: SmallMutableArray# s a -> State# s -> (# State# s, Int# #) +getSizeofSmallMutableArray# sma# s# = (# s#, sizeofSmallMutableArray# sma# #) +{-# INLINE getSizeofSmallMutableArray# #-} + +-- | Shrink SmallMutableArray# +foreign import prim "primal_stg_shrinkSmallMutableArrayzh" + shrinkSmallMutableArrayCmm# :: SmallMutableArray# s a -> Int# -> State# s -> (# State# s, Int# #) + +shrinkSmallMutableArray# :: SmallMutableArray# s a -> Int# -> State# s -> State# s +shrinkSmallMutableArray# ma# i# s = + case shrinkSmallMutableArrayCmm# ma# i# s of + (# s', _ #) -> s' +{-# INLINE shrinkSmallMutableArray# #-} + +resizeSmallMutableArray# + :: SmallMutableArray# s a -- ^ Array to resize + -> Int# -- ^ New size of array + -> a + -- ^ Newly created slots initialized to this element. + -- Only used when array is grown. + -> State# s + -> (# State# s, SmallMutableArray# s a #) +resizeSmallMutableArray# arr0 szNew a s0 = + case getSizeofSmallMutableArray# arr0 s0 of + (# s1, szOld #) -> + if isTrue# (szNew <# szOld) + then case shrinkSmallMutableArrayCmm# arr0 szNew s1 of + (# s2, _ #) -> (# s2, arr0 #) + else if isTrue# (szNew ># szOld) + then case newSmallArray# szNew a s1 of + (# s2, arr1 #) -> + case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of + s3 -> (# s3, arr1 #) + else (# s1, arr0 #) + + #endif diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Spec +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) +import Test.Hspec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/Test/Prim/ArraySpec.hs b/tests/Test/Prim/ArraySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Prim/ArraySpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +module Test.Prim.ArraySpec (spec) where + +import Data.Prim +import Foreign.Prim (IsList(..)) +import Control.Prim.Exception +import Data.Prim.Array +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.QuickCheck.Classes.Base +import Test.Hspec +import Test.Hspec.QuickCheck + +lawsSpec :: Laws -> Spec +lawsSpec Laws {..} = + describe lawsTypeclass $ mapM_ (uncurry prop) lawsProperties + +instance Arbitrary Size where + arbitrary = Size . getNonNegative <$> arbitrary + +instance Arbitrary e => Arbitrary (BArray e) where + arbitrary = arbitrary1 + +instance Arbitrary1 BArray where + liftArbitrary gen = do + sz@(Size n) <- arbitrary + fromListBArrayN sz <$> vectorOf n gen + +instance Arbitrary e => Arbitrary (SBArray e) where + arbitrary = arbitrary1 + +instance Arbitrary1 SBArray where + liftArbitrary gen = do + sz@(Size n) <- arbitrary + fromListSBArrayN sz <$> vectorOf n gen + + +instance (Prim e, Arbitrary e) => Arbitrary (UArray e) where + arbitrary = do + sz@(Size n) <- arbitrary + fromListUArrayN sz <$> vector n + + +arrayLawsSpec :: + ( Ord a + , IsList a + , Show a + , Show (Item a) + , Arbitrary a + , Arbitrary (Item a) + , Monoid a + , Semigroup a + ) + => Proxy a + -> Spec +arrayLawsSpec px = do + lawsSpec $ eqLaws px + lawsSpec $ ordLaws px + lawsSpec $ showLaws px + lawsSpec $ isListLaws px + lawsSpec $ monoidLaws px + lawsSpec $ semigroupLaws px + lawsSpec $ semigroupMonoidLaws px + +prop_writeBArrayException :: Integer -> Property +prop_writeBArrayException x = monadicIO $ run $ do + ma <- newBMArray 4 (Nothing :: Maybe Integer) + writeBMArray ma 2 (Just x) + a <- freezeBMArray ma + a `shouldBe` fromListBArray [Nothing,Nothing,Just x,Nothing] + + writeBMArray ma 2 (impureThrow DivideByZero) `shouldThrow` (== DivideByZero) + freezeBMArray ma `shouldReturn` fromListBArray [Nothing,Nothing,Just x,Nothing] + + writeBMArray ma 3 (Just (x `div` 0)) + deepevalM (readBMArray ma 3) `shouldThrow` (== DivideByZero) + deepevalM (freezeBMArray ma) `shouldThrow` (== DivideByZero) + + +spec :: Spec +spec = do + describe "BArray" $ do + arrayLawsSpec (Proxy :: Proxy (BArray Char)) + lawsSpec $ functorLaws (Proxy :: Proxy BArray) + lawsSpec $ foldableLaws (Proxy :: Proxy BArray) + prop "prop_writeBArrayException" prop_writeBArrayException + describe "SBArray" $ do + arrayLawsSpec (Proxy :: Proxy (SBArray Char)) + lawsSpec $ functorLaws (Proxy :: Proxy SBArray) + lawsSpec $ foldableLaws (Proxy :: Proxy SBArray) + describe "UArray" $ do + arrayLawsSpec (Proxy :: Proxy (UArray Char)) diff --git a/tests/Test/Prim/MVarSpec.hs b/tests/Test/Prim/MVarSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Prim/MVarSpec.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Prim.MVarSpec (spec) where + +import qualified Control.Concurrent as Base +import Control.Prim.Concurrent +import Control.Prim.Concurrent.MVar +import Control.Prim.Exception +import Data.Maybe +import Data.Prim +import Foreign.Prim.WeakPtr +import Test.Hspec +import System.Mem (performGC) + +instance Typeable a => Show (MVar a RW) where + show _ = "MVar " ++ showsType (Proxy :: Proxy a) " RW" + +data MVarException = + MVarException + deriving (Show, Eq) +instance Exception MVarException + +-- | Turn a deadlock into a failing test. +failAfter :: Int -> Expectation -> Expectation +failAfter n test = + timeout n test >>= \case + Nothing -> expectationFailure $ "Did not finish within " ++ show (n `div` 1000) ++ " ms. " + Just () -> pure () + +wit :: String -> Expectation-> Spec +wit n t = it n $ failAfter 1000000 t + +spec :: Spec +spec = do + describe "MVar" $ do + wit "isEmptyMVar" $ do + m :: MVar Int RW <- newEmptyMVar + isEmptyMVar m `shouldReturn` True + putMVar m 0 + isEmptyMVar m `shouldReturn` False + (newMVar 'H' >>= isEmptyMVar) `shouldReturn` False + wit "isSameMVar" $ do + m1 :: MVar Int RW <- newEmptyMVar + isSameMVar m1 m1 `shouldBe` True + m1 `shouldBe` m1 + m2 :: MVar Int RW <- newEmptyMVar + isSameMVar m1 m2 `shouldBe` False + m1 `shouldSatisfy` (/= m2) + wit "newMVar" $ do + m <- newMVar 'h' + readMVar m `shouldReturn` 'h' + newMVar (impureThrow MVarException) `shouldThrow` (== MVarException) + n :: MVar (Maybe Integer) RW <- newMVar (Just (impureThrow MVarException)) + mRes <- takeMVar n + mRes `shouldSatisfy` isJust + deepeval mRes `shouldThrow` (== MVarException) + wit "newLazyMVar" $ do + m <- newLazyMVar 'h' + tryTakeMVar m `shouldReturn` Just 'h' + n <- newLazyMVar (impureThrow MVarException) + evalM (takeMVar n) `shouldThrow` (== MVarException) + wit "newDeepMVar" $ do + m <- newDeepMVar 'h' + takeMVar m `shouldReturn` 'h' + newDeepMVar (impureThrow MVarException :: Int) `shouldThrow` (== MVarException) + newDeepMVar (Just (impureThrow MVarException :: Integer)) `shouldThrow` (== MVarException) + wit "putMVar" $ do + m <- newEmptyMVar + void $ fork $ putMVar m "Hello" + takeMVar m `shouldReturn` "Hello" + + n <- newMVar "World" + timeout 50000 (putMVar n "Already full") `shouldReturn` Nothing + void $ fork $ putMVar n (impureThrow MVarException) + putMVar n (impureThrow MVarException) `shouldThrow` (== MVarException) + takeMVar n `shouldReturn` "World" + + putMVar n ('f':impureThrow MVarException) + res <- takeMVar n + head res `shouldBe` 'f' + deepeval res `shouldThrow` (== MVarException) + wit "putLazyMVar" $ do + m <- newEmptyMVar + void $ fork $ putLazyMVar m "Hello" + readMVar m `shouldReturn` "Hello" + timeout 50000 (putLazyMVar m "Already full") `shouldReturn` Nothing + + n <- newEmptyMVar + void $ fork $ putLazyMVar n (impureThrow MVarException) + res <- takeMVar n + eval res `shouldThrow` (== MVarException) + wit "putDeepMVar" $ do + m <- newEmptyMVar + void $ fork $ putDeepMVar m "Hello" + readMVar m `shouldReturn` "Hello" + timeout 50000 (putDeepMVar m "Already full") `shouldReturn` Nothing + + n <- newMVar "World" + void $ fork $ putDeepMVar n ("Bar" ++ impureThrow MVarException) + putDeepMVar n ("Foo" ++ impureThrow MVarException) `shouldThrow` (== MVarException) + threadDelay 10000 + takeMVar n `shouldReturn` "World" + wit "tryPutMVar" $ do + m <- newEmptyMVar + tryPutMVar m "Hello" `shouldReturn` True + tryPutMVar m "World" `shouldReturn` False + tryPutMVar m (impureThrow MVarException) `shouldThrow` (== MVarException) + takeMVar m `shouldReturn` "Hello" + + n <- newEmptyMVar + void $ fork $ void $ tryPutMVar n (impureThrow MVarException) + tryPutMVar n (impureThrow MVarException) `shouldThrow` (== MVarException) + threadDelay 10000 + isEmptyMVar n `shouldReturn` True + wit "tryPutLazyMVar" $ do + m <- newEmptyMVar + tryPutLazyMVar m "Hello" `shouldReturn` True + tryPutLazyMVar m "World" `shouldReturn` False + tryPutLazyMVar m (impureThrow MVarException) `shouldReturn` False + takeMVar m `shouldReturn` "Hello" + + done <- newEmptyMVar + n <- newEmptyMVar + void $ fork $ do + res <- tryPutLazyMVar n (impureThrow MVarException) + void $ tryPutLazyMVar done res + takeMVar done `shouldReturn` True + isEmptyMVar n `shouldReturn` False + res <- takeMVar n + eval res `shouldThrow` (== MVarException) + wit "tryPutDeepMVar" $ do + m <- newEmptyMVar + tryPutMVar m "Hello" `shouldReturn` True + tryPutMVar m "World" `shouldReturn` False + tryPutDeepMVar m ("Happy" ++ impureThrow MVarException) `shouldThrow` (== MVarException) + takeMVar m `shouldReturn` "Hello" + + n <- newEmptyMVar + tryPutDeepMVar n ("World" ++ impureThrow MVarException) `shouldThrow` (== MVarException) + isEmptyMVar n `shouldReturn` True + wit "writeMVar" $ do + m <- newEmptyMVar + writeMVar m "Hello" + readMVar m `shouldReturn` "Hello" + writeMVar m "World" + readMVar m `shouldReturn` "World" + wit "swapMVar" $ do + m <- newMVar "Hello" + swapMVar m "World" `shouldReturn` "Hello" + swapMVar m (impureThrow MVarException) `shouldThrow` (== MVarException) + readMVar m `shouldReturn` "World" + wit "swapLazyMVar" $ do + m <- newMVar "Hello" + swapLazyMVar m "World" `shouldReturn` "Hello" + readMVar m `shouldReturn` "World" + swapLazyMVar m (impureThrow MVarException) `shouldReturn` "World" + res <- takeMVar m + eval res `shouldThrow` (== MVarException) + wit "swapDeepMVar" $ do + m <- newMVar "Hello" + swapDeepMVar m "World" `shouldReturn` "Hello" + swapDeepMVar m ("Booyah" ++ impureThrow MVarException) `shouldThrow` (== MVarException) + readMVar m `shouldReturn` "World" + wit "takeMVar" $ do + m <- newMVar "Hello" + takeMVar m `shouldReturn` "Hello" + isEmptyMVar m `shouldReturn` True + timeout 50000 (takeMVar m) `shouldReturn` Nothing + wit "tryTakeMVar" $ do + m <- newMVar "Hello" + tryTakeMVar m `shouldReturn` Just "Hello" + isEmptyMVar m `shouldReturn` True + tryTakeMVar m `shouldReturn` Nothing + wit "readMVar" $ do + m <- newMVar "Hello" + readMVar m `shouldReturn` "Hello" + isEmptyMVar m `shouldReturn` False + clearMVar m + timeout 50000 (readMVar m) `shouldReturn` Nothing + wit "tryReadMVar" $ do + m <- newEmptyMVar + tryReadMVar m `shouldReturn` Nothing + putMVar m "Hello" + tryReadMVar m `shouldReturn` Just "Hello" + isEmptyMVar m `shouldReturn` False + wit "clearMVar" $ do + m <- newEmptyMVar + clearMVar m + isEmptyMVar m `shouldReturn` True + putMVar m "Hello" + clearMVar m + isEmptyMVar m `shouldReturn` True + wit "withMVar" $ do + m <- newEmptyMVar + void $ fork $ putMVar m "Hello" + -- check masking state + res <- withMVar m $ \x -> do + x `shouldBe` "Hello" + getMaskingState + res `shouldBe` Unmasked + + -- check restoration of value on exception + withMVar m (\_ -> do + isEmptyMVar m `shouldReturn` True + throwM MVarException) + `shouldThrow` (==MVarException) + readMVar m `shouldReturn` "Hello" + + -- check that it is interruptible and that the value is overwritten + timeout 50000 (withMVar m (\_ -> putMVar m "World")) `shouldReturn` Nothing + readMVar m `shouldReturn` "World" + + -- check that it is interruptible in the exception handler and that the value is + -- overwritten + timeout 50000 (withMVar m (\_ -> do + putMVar m "Goodbye" + () <$ throwM MVarException + )) `shouldReturn` Nothing + takeMVar m `shouldReturn` "Goodbye" + + -- -- check that it is interruptible on empty + -- timeout 50000 (withMVar m pure) `shouldReturn` Nothing + + wit "withMVarMasked" $ do + m <- newMVar "Hello" + -- check masking state + res <- withMVarMasked m $ \x -> do + x `shouldBe` "Hello" + getMaskingState + res `shouldBe` MaskedInterruptible + + -- check restoration of value on exception + withMVarMasked m (\_ -> do + isEmptyMVar m `shouldReturn` True + throw MVarException) + `shouldThrow` (==MVarException) + readMVar m `shouldReturn` "Hello" + + -- check that it is interruptible and that the value is overwritten + timeout 50000 (withMVarMasked m (\_ -> putMVar m "World")) `shouldReturn` Nothing + readMVar m `shouldReturn` "World" + + -- check that it is interruptible in the exception handler and that the value is + -- overwritten + timeout 50000 (withMVarMasked m (\_ -> do + putMVar m "Goodbye" + () <$ throw MVarException + )) `shouldReturn` Nothing + takeMVar m `shouldReturn` "Goodbye" + + -- check that it is interruptible on empty + timeout 50000 (withMVarMasked m pure) `shouldReturn` Nothing + + wit "modifyMVar_" $ do + m <- newMVar "Hello" + + -- check masking state and actual modification + modifyMVar_ m $ \x -> do + x `shouldBe` "Hello" + getMaskingState `shouldReturn` Unmasked + pure $ x ++ " World" + + -- Verify value restoration on WHNF evaluation error + modifyMVar_ m (\x -> do + isEmptyMVar m `shouldReturn` True + x `shouldBe` "Hello World" + pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + readMVar m `shouldReturn` "Hello World" + + -- check that it is interruptible and that the value is overwritten + timeout 50000 (modifyMVar_ m (\_ -> putMVar m "Foo" >> pure "Bar")) `shouldReturn` Nothing + readMVar m `shouldReturn` "Foo" + + -- check that it is interruptible in the exception handler and that the value is + -- overwritten + timeout 50000 (modifyMVar_ m (\_ -> do + putMVar m "Goodbye" + "World" <$ throw MVarException + )) `shouldReturn` Nothing + takeMVar m `shouldReturn` "Goodbye" + + -- check that it is interruptible on empty + timeout 50000 (modifyMVar_ m pure) `shouldReturn` Nothing + wit "modifyMVarMasked_" $ do + m <- newMVar "Hello" + + -- check masking state and actual modification + modifyMVarMasked_ m $ \x -> do + x `shouldBe` "Hello" + getMaskingState `shouldReturn` MaskedInterruptible + pure $ x ++ " World" + + -- Verify value restoration on WHNF evaluation error + modifyMVarMasked_ m (\x -> do + isEmptyMVar m `shouldReturn` True + x `shouldBe` "Hello World" + pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + readMVar m `shouldReturn` "Hello World" + + -- check that it is interruptible and that the value is overwritten + timeout 50000 (modifyMVarMasked_ m (\_ -> putMVar m "Foo" >> pure "Bar")) + `shouldReturn` Nothing + readMVar m `shouldReturn` "Foo" + + -- check that it is interruptible in the exception handler and that the value is + -- overwritten + timeout 50000 (modifyMVarMasked_ m (\_ -> do + putMVar m "Goodbye" + "World" <$ throw MVarException + )) `shouldReturn` Nothing + takeMVar m `shouldReturn` "Goodbye" + + -- check that it is interruptible on empty + timeout 50000 (modifyMVarMasked_ m pure) `shouldReturn` Nothing + wit "modifyFetchOldMVar" $ do + m <- newMVar "Hello" + modifyFetchOldMVar m (pure . (++ " World")) `shouldReturn` "Hello" + readMVar m `shouldReturn` "Hello World" + modifyFetchOldMVar m (\ _ -> pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + takeMVar m `shouldReturn` "Hello World" + wit "modifyFetchOldMVarMasked" $ do + m <- newMVar "Hello" + modifyFetchOldMVarMasked m (pure . (++ " World")) `shouldReturn` "Hello" + readMVar m `shouldReturn` "Hello World" + modifyFetchOldMVarMasked m (\ _ -> pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + takeMVar m `shouldReturn` "Hello World" + wit "modifyFetchNewMVar" $ do + m <- newMVar "Hello" + modifyFetchNewMVar m (pure . (++ " World")) `shouldReturn` "Hello World" + readMVar m `shouldReturn` "Hello World" + modifyFetchNewMVar m (\ _ -> pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + takeMVar m `shouldReturn` "Hello World" + wit "modifyFetchNewMVarMasked" $ do + m <- newMVar "Hello" + modifyFetchNewMVarMasked m (pure . (++ " World")) `shouldReturn` "Hello World" + readMVar m `shouldReturn` "Hello World" + modifyFetchNewMVarMasked m (\ _ -> pure $ impureThrow MVarException) + `shouldThrow` (==MVarException) + takeMVar m `shouldReturn` "Hello World" + -- xit "modifyMVar" (pure () :: IO ()) + -- xit "modifyMVarMasked" (pure () :: IO ()) + it "toBaseMVar" $ do + m <- newMVar () + Base.takeMVar (toBaseMVar m) `shouldReturn` () + isEmptyMVar m `shouldReturn` True + it "fromBaseMVar" $ do + m <- Base.newMVar () + takeMVar (fromBaseMVar m) `shouldReturn` () + Base.isEmptyMVar m `shouldReturn` True + describe "mkWeakMVar" $ do + wit "performGC" $ do + sem <- newEmptyMVar + void $ fork $ do + m <- newEmptyMVar + _weak <- mkWeakMVar m $ putMVar sem () + performGC + takeMVar sem `shouldReturn` () + wit "finalizeWeak" $ do + sem <- newEmptyMVar + m <- newMVar "Hello" + weak <- mkWeakMVar m $ putMVar sem () + deRefWeak weak >>= \case + Nothing -> expectationFailure "Empty weak ref" + Just m' -> do + m' `shouldBe` m + readMVar m' `shouldReturn` "Hello" + finalizeWeak weak + takeMVar sem `shouldReturn` () + diff --git a/tests/Test/Prim/RefSpec.hs b/tests/Test/Prim/RefSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Prim/RefSpec.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Prim.RefSpec (spec) where + +import qualified Control.Concurrent as Base +import Control.Prim.Concurrent +import Data.Prim.Ref +import Control.Prim.Exception +import Data.Maybe +import Data.Prim +import Foreign.Prim.WeakPtr +import Test.Hspec +import System.Mem (performGC) + +instance Typeable a => Show (Ref a RW) where + show _ = "Ref " ++ showsType (Proxy :: Proxy a) " RW" + +data RefException = + RefException + deriving (Show, Eq) +instance Exception RefException + + +spec :: Spec +spec = do + describe "Ref" $ do + it "isSameRef" $ do + ref1 <- newRef () + isSameRef ref1 ref1 `shouldBe` True + ref1 `shouldBe` ref1 + ref2 <- newRef () + isSameRef ref1 ref2 `shouldBe` False + ref1 `shouldSatisfy` (/= ref2) + it "newRef" $ do + ref <- newRef 'h' + readRef ref `shouldReturn` 'h' + newRef (impureThrow RefException) `shouldThrow` (== RefException) + n :: Ref (Maybe Integer) RW <- newRef (Just (impureThrow RefException)) + mRes <- readRef n + mRes `shouldSatisfy` isJust + deepeval mRes `shouldThrow` (== RefException) + it "newLazyRef" $ do + ref <- newLazyRef 'h' + readRef ref `shouldReturn` 'h' + n <- newLazyRef (impureThrow RefException) + evalM (readRef n) `shouldThrow` (== RefException) + it "newDeepRef" $ do + ref <- newDeepRef 'h' + readRef ref `shouldReturn` 'h' + newDeepRef (impureThrow RefException :: Int) `shouldThrow` (== RefException) + newDeepRef (Just (impureThrow RefException :: Integer)) `shouldThrow` (== RefException) + it "readRef" $ do + ref <- newRef "Hello" + readRef ref `shouldReturn` "Hello" + it "writeRef" $ do + ref <- newRef "Hello" + readRef ref `shouldReturn` "Hello" + writeRef ref "World" + readRef ref `shouldReturn` "World" + it "swapRef" $ do + ref <- newRef "Hello" + swapRef ref "World" `shouldReturn` "Hello" + swapRef ref (impureThrow RefException) `shouldThrow` (== RefException) + readRef ref `shouldReturn` "World" + it "swapLazyRef" $ do + ref <- newRef "Hello" + swapLazyRef ref "World" `shouldReturn` "Hello" + readRef ref `shouldReturn` "World" + swapLazyRef ref (impureThrow RefException) `shouldReturn` "World" + res <- readRef ref + eval res `shouldThrow` (== RefException) + it "swapDeepRef" $ do + ref <- newRef "Hello" + swapDeepRef ref "World" `shouldReturn` "Hello" + swapDeepRef ref ("Booyah" ++ impureThrow RefException) `shouldThrow` (== RefException) + readRef ref `shouldReturn` "World" + it "modifyRef" $ do + ref <- newRef "Hello" + modifyRef ref (\x -> (x ++ " World", length x)) `shouldReturn` 5 + flip shouldThrow (== RefException) $ modifyRef ref $ \x -> (impureThrow RefException, x) + readRef ref `shouldReturn` "Hello World" + _ <- modifyRef ref $ \x -> (x ++ "!!!", impureThrow RefException) + readRef ref `shouldReturn` "Hello World!!!" + -- it "modifyFetchOldRef" $ do + -- ref <- newRef "Hello" + -- modifyRef ref (++ " World") `shouldReturn` "Hello" + -- flip shouldThrow (== RefException) $ modifyRef ref $ \_ -> impureThrow RefException + -- readRef ref `shouldReturn` "Hello World" + it "modifyRefM_" $ do + ref <- newRef "Hello" + modifyRefM_ ref $ \x -> do + x `shouldBe` "Hello" + pure $ x ++ " World" + flip shouldThrow (== RefException) $ modifyRefM_ ref $ \x -> do + x `shouldBe` "Hello World" + pure $ impureThrow RefException + readRef ref `shouldReturn` "Hello World" + + -- -- Verify value restoration on WHNF evaluation error + -- modifyRef_ ref (\x -> do + -- isEmptyRef ref `shouldReturn` True + -- x `shouldBe` "Hello World" + -- pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- readRef ref `shouldReturn` "Hello World" + + -- -- check that it is interruptible and that the value is overwritten + -- timeout 50000 (modifyRef_ ref (\_ -> putRef ref "Foo" >> pure "Bar")) `shouldReturn` Nothing + -- readRef ref `shouldReturn` "Foo" + + -- -- check that it is interruptible in the exception handler and that the value is + -- -- overwritten + -- timeout 50000 (modifyRef_ ref (\_ -> do + -- putRef ref "Goodbye" + -- "World" <$ throw RefException + -- )) `shouldReturn` Nothing + -- takeRef ref `shouldReturn` "Goodbye" + + -- -- check that it is interruptible on empty + -- timeout 50000 (modifyRef_ ref pure) `shouldReturn` Nothing + -- it "modifyRefMasked_" $ do + -- ref <- newRef "Hello" + + -- -- check masking state and actual modification + -- modifyRefMasked_ ref $ \x -> do + -- x `shouldBe` "Hello" + -- getMaskingState `shouldReturn` MaskedInterruptible + -- pure $ x ++ " World" + + -- -- Verify value restoration on WHNF evaluation error + -- modifyRefMasked_ ref (\x -> do + -- isEmptyRef ref `shouldReturn` True + -- x `shouldBe` "Hello World" + -- pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- readRef ref `shouldReturn` "Hello World" + + -- -- check that it is interruptible and that the value is overwritten + -- timeout 50000 (modifyRefMasked_ ref (\_ -> putRef ref "Foo" >> pure "Bar")) + -- `shouldReturn` Nothing + -- readRef ref `shouldReturn` "Foo" + + -- -- check that it is interruptible in the exception handler and that the value is + -- -- overwritten + -- timeout 50000 (modifyRefMasked_ ref (\_ -> do + -- putRef ref "Goodbye" + -- "World" <$ throw RefException + -- )) `shouldReturn` Nothing + -- takeRef ref `shouldReturn` "Goodbye" + + -- -- check that it is interruptible on empty + -- timeout 50000 (modifyRefMasked_ ref pure) `shouldReturn` Nothing + -- it "modifyFetchOldRef" $ do + -- ref <- newRef "Hello" + -- modifyFetchOldRef ref (pure . (++ " World")) `shouldReturn` "Hello" + -- readRef ref `shouldReturn` "Hello World" + -- modifyFetchOldRef ref (\ _ -> pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- takeRef ref `shouldReturn` "Hello World" + -- it "modifyFetchOldRefMasked" $ do + -- ref <- newRef "Hello" + -- modifyFetchOldRefMasked ref (pure . (++ " World")) `shouldReturn` "Hello" + -- readRef ref `shouldReturn` "Hello World" + -- modifyFetchOldRefMasked ref (\ _ -> pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- takeRef ref `shouldReturn` "Hello World" + -- it "modifyFetchNewRef" $ do + -- ref <- newRef "Hello" + -- modifyFetchNewRef ref (pure . (++ " World")) `shouldReturn` "Hello World" + -- readRef ref `shouldReturn` "Hello World" + -- modifyFetchNewRef ref (\ _ -> pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- takeRef ref `shouldReturn` "Hello World" + -- it "modifyFetchNewRefMasked" $ do + -- ref <- newRef "Hello" + -- modifyFetchNewRefMasked ref (pure . (++ " World")) `shouldReturn` "Hello World" + -- readRef ref `shouldReturn` "Hello World" + -- modifyFetchNewRefMasked ref (\ _ -> pure $ impureThrow RefException) + -- `shouldThrow` (==RefException) + -- takeRef ref `shouldReturn` "Hello World" + -- -- xit "modifyRef" (pure () :: IO ()) + -- -- xit "modifyRefMasked" (pure () :: IO ()) + -- it "toBaseRef" $ do + -- ref <- newRef () + -- Base.takeRef (toBaseRef ref) `shouldReturn` () + -- isEmptyRef ref `shouldReturn` True + -- it "fromBaseRef" $ do + -- ref <- Base.newRef () + -- takeRef (fromBaseRef ref) `shouldReturn` () + -- Base.isEmptyRef ref `shouldReturn` True + -- describe "mkWeakRef" $ do + -- it "performGC" $ do + -- seref <- newEmptyRef + -- void $ fork $ do + -- ref <- newEmptyRef + -- _weak <- mkWeakRef ref $ putRef seref () + -- performGC + -- takeRef seref `shouldReturn` () + -- it "finalizeWeak" $ do + -- seref <- newEmptyRef + -- ref <- newRef "Hello" + -- weak <- mkWeakRef ref $ putRef seref () + -- deRefWeak weak >>= \case + -- Nothing -> expectationFailure "Empty weak ref" + -- Just ref' -> do + -- ref' `shouldBe` ref + -- readRef ref' `shouldReturn` "Hello" + -- finalizeWeak weak + -- takeRef sem `shouldReturn` () + diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,6 +1,17 @@ +{-# LANGUAGE CPP #-} module Main where +#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ != 810 + import Test.DocTest (doctest) main :: IO () main = doctest ["src", "-fobject-code"] + +#else + +-- TODO: fix doctest support +main :: IO () +main = putStrLn "\nDoctests are not supported for older ghc version\n" + +#endif