primal 0.2.0.0 → 0.3.0.0
raw patch · 27 files changed
+6514/−386 lines, 27 filesdep +QuickCheckdep +arraydep +atomic-primopsdep ~basedep ~transformers
Dependencies added: QuickCheck, array, atomic-primops, bytestring, criterion, hspec, quickcheck-classes-base, unliftio
Dependency ranges changed: base, transformers
Files
- CHANGELOG.md +16/−0
- bench/MVar.hs +122/−0
- cbits/primal_compat.c +17/−0
- cbits/primal_stg.cmm +34/−0
- primal.cabal +55/−5
- src/Control/Prim/Concurrent.hs +107/−24
- src/Control/Prim/Concurrent/MVar.hs +500/−0
- src/Control/Prim/Eval.hs +87/−31
- src/Control/Prim/Exception.hs +473/−132
- src/Control/Prim/Monad.hs +23/−9
- src/Control/Prim/Monad/Internal.hs +131/−30
- src/Control/Prim/Monad/Throw.hs +11/−13
- src/Control/Prim/Monad/Unsafe.hs +23/−2
- src/Data/Prim.hs +30/−8
- src/Data/Prim/Array.hs +3117/−0
- src/Data/Prim/Atom.hs +117/−113
- src/Data/Prim/Class.hs +11/−3
- src/Data/Prim/Ref.hs +778/−0
- src/Foreign/Prim.hs +15/−1
- src/Foreign/Prim/C/LtGHC806.hs +55/−15
- src/Foreign/Prim/Cmm.hs +88/−0
- tests/Main.hs +11/−0
- tests/Spec.hs +1/−0
- tests/Test/Prim/ArraySpec.hs +93/−0
- tests/Test/Prim/MVarSpec.hs +376/−0
- tests/Test/Prim/RefSpec.hs +212/−0
- tests/doctests.hs +11/−0
CHANGELOG.md view
@@ -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`
+ bench/MVar.hs view
@@ -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, ())+ ]+ ]
cbits/primal_compat.c view
@@ -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
cbits/primal_stg.cmm view
@@ -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); }
primal.cabal view
@@ -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 <https://github.com/lehins/primal#readme> 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
src/Control/Prim/Concurrent.hs view
@@ -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
+ src/Control/Prim/Concurrent/MVar.hs view
@@ -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 <alexey@kuleshevi.ch>+-- 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 #-}
src/Control/Prim/Eval.hs view
@@ -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` ()
src/Control/Prim/Exception.hs view
@@ -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 <alexey@kuleshevi.ch>--- 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 <alexey@kuleshevi.ch> +-- 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
src/Control/Prim/Monad.hs view
@@ -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
src/Control/Prim/Monad/Internal.hs view
@@ -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_ #-}
src/Control/Prim/Monad/Throw.hs view
@@ -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
src/Control/Prim/Monad/Unsafe.hs view
@@ -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 --
src/Data/Prim.hs view
@@ -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 (.#) #-}
+ src/Data/Prim/Array.hs view
@@ -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 <alexey@kuleshevi.ch>+-- 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 #-}
src/Data/Prim/Atom.hs view
@@ -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# #-}
src/Data/Prim/Class.hs view
@@ -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
+ src/Data/Prim/Ref.hs view
@@ -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 <alexey@kuleshevi.ch>+-- 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) #))++
src/Foreign/Prim.hs view
@@ -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# #)
src/Foreign/Prim/C/LtGHC806.hs view
@@ -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 */
src/Foreign/Prim/Cmm.hs view
@@ -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
+ tests/Main.hs view
@@ -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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ tests/Test/Prim/ArraySpec.hs view
@@ -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))
+ tests/Test/Prim/MVarSpec.hs view
@@ -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` ()+
+ tests/Test/Prim/RefSpec.hs view
@@ -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` ()+
tests/doctests.hs view
@@ -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