diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,29 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 2.2.0.0 -- 2024-10-05 + +* Similarly to the change in 2.1.0.0, change the order of the type arguments to `SmallUnliftedArray_` and + `SmallMutableUnliftedArray_`. This makes the library work better with + the typeclasses in the `contiguous` library. + +## 2.1.0.0 -- 2023-06-28 + +* Change the order of the type arguments to `UnliftedArray_` and + `MutableUnliftedArray_`. This makes the library work better with + the typeclasses in the `contiguous` library. + +## 2.0.0.0 -- 2023-06-27 + +* Use legitimate unlifted primitive types and operations, only supporting + GHC 9.4 and newer. + +## 1.0.0.0 -- 2020-11-02 + +* Redo everything. This uses `unsafeCoerce#` a lot to coerce between + lifted and unlifted types. Stay on the 0.1.x.x series unless you need + something from this newer version. + ## 0.1.3.0 -- 2020-01-23 * Add `PrimUnlifted` instances for `ShortText` and `ShortByteString`. diff --git a/primitive-unlifted.cabal b/primitive-unlifted.cabal --- a/primitive-unlifted.cabal +++ b/primitive-unlifted.cabal @@ -1,13 +1,15 @@ cabal-version: 2.2 name: primitive-unlifted -version: 0.1.3.1 +version: 2.2.0.0 synopsis: Primitive GHC types with unlifted types inside description: Primitive GHC types with unlifted types inside. There used to be a module named `Data.Primitive.UnliftedArray` in the - `primitive` library. However, the techniques it used were - unsound in the presence of certain FFI calls. This library - a successor to that module. + `primitive` library. However, it turns out that it is impossible + to write such an API safely in versions of GHC before 8.10.1, thanks + to some nasty interactions between unsafe coercions and the foreign + function interface. This package also uses a somewhat different, + and more flexible, approach than that module did. homepage: https://github.com/haskell-primitive/primitive-unlifted bug-reports: https://github.com/haskell-primitive/primitive-unlifted/issues license: BSD-3-Clause @@ -17,29 +19,51 @@ copyright: 2019 Andrew Martin category: Data extra-source-files: CHANGELOG.md -tested-with: GHC == 8.4.4, GHC == 8.6.5 +tested-with: GHC == 9.4.5 library exposed-modules: Data.Primitive.Unlifted.Class Data.Primitive.Unlifted.Array + Data.Primitive.Unlifted.SmallArray + Data.Primitive.Unlifted.SmallArray.ST + Data.Primitive.Unlifted.SmallArray.Primops + Data.Primitive.Unlifted.Array.ST + Data.Primitive.Unlifted.Array.Primops + Data.Primitive.Unlifted.MutVar.Primops + Data.Primitive.Unlifted.MutVar.ST + Data.Primitive.Unlifted.MutVar + Data.Primitive.Unlifted.Box + Data.Primitive.Unlifted.Weak + Data.Primitive.Unlifted.Weak.IO + Data.Primitive.Unlifted.Weak.Primops + Data.Primitive.TArray.Classic + Data.Primitive.Unlifted.MVar + Data.Primitive.Unlifted.MVar.ST + Data.Primitive.Unlifted.MVar.Primops + Data.Primitive.Unlifted.Type build-depends: - , base >=4.11.1.0 && <5 - , bytestring >=0.10.8.2 && <0.12 - , primitive >= 0.7 && <0.8 + , base >=4.17.1.0 && <5 + , bytestring >=0.10.8.2 && <0.13 + , primitive >= 0.7 && <0.10 , text-short >=0.1.3 && <0.2 + , array hs-source-dirs: src ghc-options: -Wall -O2 default-language: Haskell2010 -test-suite unit +test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Unit.hs + main-is: Main.hs build-depends: , base , primitive-unlifted - , primitive + , primitive >=0.9 + , quickcheck-classes-base + , QuickCheck + , tasty-quickcheck + , tasty , stm ghc-options: -Wall -O2 default-language: Haskell2010 diff --git a/src/Data/Primitive/TArray/Classic.hs b/src/Data/Primitive/TArray/Classic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/TArray/Classic.hs @@ -0,0 +1,106 @@ +{-# language MagicHash #-} +{-# language MultiParamTypeClasses #-} +{-# language ScopedTypeVariables #-} +{-# language BangPatterns #-} +{-# language FlexibleInstances #-} +{-# language RoleAnnotations #-} +{- OPTIONS_GHC -ddump-simpl #-} + + +{- | +This module is a drop-in replacement for @Control.Concurrent.STM.TArray@ +in the @stm@ package. It has the same fundamental inefficiency of the +classic @TArray@, but it's a /little/ faster and more compact. +Specifically, this implementation uses two fewer words of memory +and one fewer indirection per element. +We also add an 'MArray' instance for working in 'IO' that the 'stm' +version lacks. +Finally, the 'Eq' instance for the official @TArray@ is currently a little broken +thanks to a bug in the instance for @Data.Array.Array@ (See GHC Gitlab issue +#18700). We fix that bug here. +-} + +module Data.Primitive.TArray.Classic (TArray) where +import GHC.Conc (STM, TVar, newTVar, readTVar, writeTVar + , newTVarIO, readTVarIO, atomically) +import Data.Primitive.Unlifted.Array +import Data.Array.Base (MArray (..)) +import Data.Ix (Ix, rangeSize) +import GHC.Exts (TVar#, RealWorld) + +data TArray i a = TArray { + _lb :: !i -- the lower bound + , _ub :: !i -- the upper bound + , range :: !Int -- A cache of (rangeSize (l, u)) + -- used to make sure an index is really in range + , arr :: !(UnliftedArray_ (TVar# RealWorld a) (TVar a)) + } +type role TArray nominal representational + +instance Eq i => Eq (TArray i a) where + -- There's no way for TVars to move from one TArray to another, so two of + -- them are equal iff they're both empty, with the same bounds, or they're + -- actually the same array. There's no "safe" way to check if they're the + -- same array (though we can use `unsafeCoerce#` with + -- `sameMutableUnliftedArray#` if we want to). But we can just do a quick size + -- check and then look at the first TVar of each. + -- + -- Note: The instance in stm leans on the instance for @Array@ in @base@. As + -- of base-4.14.0.0, that instance is broken. See GHC Gitlab issue #18700. It + -- looks like that's probably going to get fixed, so we fix it here. + TArray lb1 ub1 range1 arr1 == TArray lb2 ub2 range2 arr2 + | range1 /= range2 = False + -- If the arrays are both empty, then they may still have been + -- created with different bounds (e.g., (2,1) and (1,0)), so we + -- check. + | range1 == 0 = lb1 == lb2 && ub1 == ub2 + -- If the arrays are not empty, but the first TVar of each is the + -- same, then they must have been created by the *same* newArray + -- action. Therefore they are sure to have the same bounds, and + -- are equal. + | otherwise = indexUnliftedArray arr1 0 == indexUnliftedArray arr2 0 + +instance MArray TArray e STM where + getBounds (TArray l u _ _) = pure (l, u) + newArray b e = do + tvs <- rep (rangeSize b) (newTVar e) + return $ listTArray b tvs + -- The stm version defines newArray_, but the default does the + -- same thing. + unsafeRead tarr i = readTVar $ indexUnliftedArray (arr tarr) i + unsafeWrite tarr i e = writeTVar (indexUnliftedArray (arr tarr) i) e + getNumElements !tarr = pure (range tarr) + +-- | Writes are slow in 'IO'. +instance MArray TArray e IO where + getBounds (TArray l u _ _) = pure (l, u) + newArray b e = do + tvs <- rep (rangeSize b) (newTVarIO e) + return $ listTArray b tvs + -- The stm version defines newArray_, but the default does the + -- same thing. + unsafeRead tarr i = readTVarIO $ indexUnliftedArray (arr tarr) i + unsafeWrite tarr i e = atomically $ writeTVar (indexUnliftedArray (arr tarr) i) e + getNumElements !tarr = pure (range tarr) + +-- | Stolen from stm: +-- Like 'replicateM' but uses an accumulator to prevent stack overflows. +-- Unlike 'replicateM' the returned list is in reversed order. +-- This doesn't matter though since this function is only used to create +-- arrays with identical elements. +-- +-- TODO: For `IO`, we should surely build the array directly, rather +-- than first making a list. For STM, I'm *guessing* this would be a +-- safe place to use unsafeIOtoSTM to do the same. +rep :: Monad m => Int -> m a -> m [a] +rep n m = go n [] + where + go 0 xs = return xs + go i xs = do + x <- m + go (i-1) (x:xs) + +listTArray :: Ix i => (i, i) -> [TVar e] -> TArray i e +listTArray (l, u) tvs = TArray l u n (unliftedArrayFromListN n tvs) + where + !n = rangeSize (l, u) diff --git a/src/Data/Primitive/Unlifted/Array.hs b/src/Data/Primitive/Unlifted/Array.hs --- a/src/Data/Primitive/Unlifted/Array.hs +++ b/src/Data/Primitive/Unlifted/Array.hs @@ -4,115 +4,83 @@ {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-} {-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} -- | -- GHC contains three general classes of value types: -- --- 1. Unboxed types: values are machine values made up of fixed numbers of bytes --- 2. Unlifted types: values are pointers, but strictly evaluated --- 3. Lifted types: values are pointers, lazily evaluated --- --- The first category can be stored in a 'ByteArray', and this allows types in --- category 3 that are simple wrappers around category 1 types to be stored --- more efficiently using a 'ByteArray'. This module provides the same facility --- for category 2 types. --- --- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These --- are arrays of pointers, but of category 2 values, so they are known to not --- be bottom. This allows types that are wrappers around such types to be stored --- in an array without an extra level of indirection. +-- 1. Unboxed types: values are machine values made up of fixed numbers of bytes. +-- These include types like @Int#@, @Char#@ and @Addr#@. +-- 2. Unlifted types: values are pointers, but strictly evaluated. These include +-- types like @MutVar# s a@, @Array# a@, and @MVar# s a@. +-- 3. Lifted types: values are pointers, lazily evaluated. -- --- The way that the 'ArrayArray#' API works is that one can read and write --- 'ArrayArray#' values to the positions. This works because all category 2 --- types share a uniform representation, unlike unboxed values which are --- represented by varying (by type) numbers of bytes. However, using the --- this makes the internal API very unsafe to use, as one has to coerce values --- to and from 'ArrayArray#'. +-- Certain lifted types are really just thin wrappers around unboxed types (we can call +-- these category 3a) or unlifted pointer types (we can call these category 3b) +-- Category 3a includes `Int`, `Char`, and `Ptr a`, while category 3b includes +-- @IORef a@, @Data.Primitive.Array.Array a@, and @MVar a@. -- --- The API presented by this module is more type safe. 'UnliftedArray' and --- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and --- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things --- that are eligible to be stored. +-- Types in category 3a can be stored efficiently in a @Data.Primitive.PrimArray.PrimArray@, +-- removing and applying wrappers as required. This module provides the same facility for +-- types in category 3b. module Data.Primitive.Unlifted.Array ( -- * Types - UnliftedArray(..) - , MutableUnliftedArray(..) + A.UnliftedArray_(..) + , A.UnliftedArray + , A.MutableUnliftedArray_(..) + , A.MutableUnliftedArray -- * Operations , newUnliftedArray , unsafeNewUnliftedArray - , sizeofUnliftedArray - , sizeofMutableUnliftedArray - , sameMutableUnliftedArray + , A.sizeofUnliftedArray + , A.sizeofMutableUnliftedArray + , A.sameMutableUnliftedArray , writeUnliftedArray , readUnliftedArray - , indexUnliftedArray + , A.indexUnliftedArray , unsafeFreezeUnliftedArray , freezeUnliftedArray , thawUnliftedArray + , unsafeThawUnliftedArray , setUnliftedArray , copyUnliftedArray , copyMutableUnliftedArray - , cloneUnliftedArray + , A.cloneUnliftedArray , cloneMutableUnliftedArray - , emptyUnliftedArray - , singletonUnliftedArray - , runUnliftedArray + , A.emptyUnliftedArray + , A.singletonUnliftedArray + , A.runUnliftedArray + , A.dupableRunUnliftedArray -- * List Conversion - , unliftedArrayToList - , unliftedArrayFromList - , unliftedArrayFromListN + , A.unliftedArrayToList + , A.unliftedArrayFromList + , A.unliftedArrayFromListN -- * Folding - , foldrUnliftedArray - , foldrUnliftedArray' - , foldlUnliftedArray - , foldlUnliftedArray' - , foldlUnliftedArrayM' + , A.foldrUnliftedArray + , A.foldrUnliftedArray' + , A.foldlUnliftedArray + , A.foldlUnliftedArray' + , A.foldlUnliftedArrayM' -- * Traversals - , traverseUnliftedArray_ - , itraverseUnliftedArray_ + , A.traverseUnliftedArray_ + , A.itraverseUnliftedArray_ -- * Mapping - , mapUnliftedArray + , A.mapUnliftedArray ) where -import Control.Monad.Primitive (PrimMonad,PrimState,primitive,primitive_) -import Control.Monad.ST (ST) -import Data.Primitive.Unlifted.Class (PrimUnlifted) -import GHC.Exts (Int(I#),MutableArrayArray#,ArrayArray#,State#) - -import qualified Data.List as L -import qualified Data.Primitive.Unlifted.Class as C -import qualified GHC.Exts as Exts -import qualified GHC.ST as ST - -data MutableUnliftedArray s a - = MutableUnliftedArray (MutableArrayArray# s) - -data UnliftedArray a - = UnliftedArray ArrayArray# - --- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it --- initializes all elements of the array as pointers to the array itself. Attempting --- to read one of these elements before writing to it is in effect an unsafe --- coercion from the @'MutableUnliftedArray' s a@ to the element type. -unsafeNewUnliftedArray - :: (PrimMonad m) - => Int -- ^ size - -> m (MutableUnliftedArray (PrimState m) a) -{-# inline unsafeNewUnliftedArray #-} -unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case Exts.newArrayArray# i# s of - (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) +import Control.Monad.Primitive (PrimMonad,PrimState,stToPrim) +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import qualified Data.Primitive.Unlifted.Array.ST as A +import Data.Primitive.Unlifted.Array.ST (UnliftedArray, MutableUnliftedArray) -- | Creates a new 'MutableUnliftedArray' with the specified value as initial --- contents. This is slower than 'unsafeNewUnliftedArray', but safer. +-- contents. newUnliftedArray :: (PrimMonad m, PrimUnlifted a) => Int -- ^ size -> a -- ^ initial value -> m (MutableUnliftedArray (PrimState m) a) -newUnliftedArray len v = do - mua <- unsafeNewUnliftedArray len - setUnliftedArray mua v 0 len - pure mua +newUnliftedArray len v = stToPrim $ A.newUnliftedArray len v {-# inline newUnliftedArray #-} setUnliftedArray @@ -123,22 +91,7 @@ -> Int -- ^ length -> m () {-# inline setUnliftedArray #-} -setUnliftedArray mua v off len = loop (len + off - 1) - where - loop i - | i < off = pure () - | otherwise = writeUnliftedArray mua i v *> loop (i-1) - --- | Yields the length of an 'UnliftedArray'. -sizeofUnliftedArray :: UnliftedArray e -> Int -{-# inline sizeofUnliftedArray #-} -sizeofUnliftedArray (UnliftedArray aa#) = I# (Exts.sizeofArrayArray# aa#) - --- | Yields the length of a 'MutableUnliftedArray'. -sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int -{-# inline sizeofMutableUnliftedArray #-} -sizeofMutableUnliftedArray (MutableUnliftedArray maa#) - = I# (Exts.sizeofMutableArrayArray# maa#) +setUnliftedArray mua v off len = stToPrim $ A.setUnliftedArray mua v off len writeUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a @@ -146,50 +99,28 @@ -> a -> m () {-# inline writeUnliftedArray #-} -writeUnliftedArray (MutableUnliftedArray arr) (I# ix) a = - primitive_ (C.writeUnliftedArray# arr ix a) +writeUnliftedArray mary ix a = stToPrim $ A.writeUnliftedArray mary ix a readUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m a {-# inline readUnliftedArray #-} -readUnliftedArray (MutableUnliftedArray arr) (I# ix) = - primitive (C.readUnliftedArray# arr ix) - -indexUnliftedArray :: PrimUnlifted a - => UnliftedArray a - -> Int - -> a -{-# inline indexUnliftedArray #-} -indexUnliftedArray (UnliftedArray arr) (I# ix) = - C.indexUnliftedArray# arr ix +readUnliftedArray mary ix = stToPrim $ A.readUnliftedArray mary ix -- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply -- marks the array as frozen in place, so it should only be used when no further -- modifications to the mutable array will be performed. unsafeFreezeUnliftedArray - :: (PrimMonad m) + :: PrimMonad m => MutableUnliftedArray (PrimState m) a -> m (UnliftedArray a) -unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) - = primitive $ \s -> case Exts.unsafeFreezeArrayArray# maa# s of - (# s', aa# #) -> (# s', UnliftedArray aa# #) +unsafeFreezeUnliftedArray mary = stToPrim $ A.unsafeFreezeUnliftedArray mary {-# inline unsafeFreezeUnliftedArray #-} --- | Determines whether two 'MutableUnliftedArray' values are the same. This is --- object/pointer identity, not based on the contents. -sameMutableUnliftedArray - :: MutableUnliftedArray s a - -> MutableUnliftedArray s a - -> Bool -sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) - = Exts.isTrue# (Exts.sameMutableArrayArray# maa1# maa2#) -{-# inline sameMutableUnliftedArray #-} - -- | Copies the contents of an immutable array into a mutable array. copyUnliftedArray - :: (PrimMonad m) + :: PrimMonad m => MutableUnliftedArray (PrimState m) a -- ^ destination -> Int -- ^ offset into destination -> UnliftedArray a -- ^ source @@ -197,15 +128,11 @@ -> Int -- ^ number of elements to copy -> m () {-# inline copyUnliftedArray #-} -copyUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (UnliftedArray src) (I# soff) (I# ln) = - primitive_ $ Exts.copyArrayArray# src soff dst doff ln - +copyUnliftedArray dst doff src soff ln = stToPrim $ A.copyUnliftedArray dst doff src soff ln -- | Copies the contents of one mutable array into another. copyMutableUnliftedArray - :: (PrimMonad m) + :: PrimMonad m => MutableUnliftedArray (PrimState m) a -- ^ destination -> Int -- ^ offset into destination -> MutableUnliftedArray (PrimState m) a -- ^ source @@ -213,78 +140,51 @@ -> Int -- ^ number of elements to copy -> m () {-# inline copyMutableUnliftedArray #-} -copyMutableUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (MutableUnliftedArray src) (I# soff) (I# ln) = - primitive_ $ Exts.copyMutableArrayArray# src soff dst doff ln - +copyMutableUnliftedArray dst doff src soff ln = stToPrim $ A.copyMutableUnliftedArray dst doff src soff ln -- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. -- This operation is safe, in that it copies the frozen portion, and the -- existing mutable array may still be used afterward. freezeUnliftedArray - :: (PrimMonad m) + :: PrimMonad m => MutableUnliftedArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (UnliftedArray a) -freezeUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - unsafeFreezeUnliftedArray dst +freezeUnliftedArray mary off len = stToPrim $ A.freezeUnliftedArray mary off len {-# inline freezeUnliftedArray #-} - -- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. -- This copies the thawed portion, so mutations will not affect the original -- array. thawUnliftedArray - :: (PrimMonad m) + :: PrimMonad m => UnliftedArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) {-# inline thawUnliftedArray #-} -thawUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyUnliftedArray dst 0 src off len - return dst - -unsafeCreateUnliftedArray - :: Int - -> (forall s. MutableUnliftedArray s a -> ST s ()) - -> UnliftedArray a -unsafeCreateUnliftedArray !n f = runUnliftedArray $ do - mary <- unsafeNewUnliftedArray n - f mary - pure mary - --- | Execute a stateful computation and freeze the resulting array. -runUnliftedArray - :: (forall s. ST s (MutableUnliftedArray s a)) - -> UnliftedArray a -{-# INLINE runUnliftedArray #-} -runUnliftedArray m = UnliftedArray (runUnliftedArray# m) - -runUnliftedArray# - :: (forall s. ST s (MutableUnliftedArray s a)) - -> ArrayArray# -runUnliftedArray# m = case Exts.runRW# $ \s -> - case unST m s of { (# s', MutableUnliftedArray mary# #) -> - Exts.unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary# +thawUnliftedArray ary off len = stToPrim $ A.thawUnliftedArray ary off len -unST :: ST s a -> State# s -> (# State# s, a #) -unST (ST.ST f) = f +-- | Thaws an 'UnliftedArray', yielding a 'MutableUnliftedArray'. +-- This does not make a copy. +unsafeThawUnliftedArray + :: PrimMonad m + => UnliftedArray a -- ^ source + -> m (MutableUnliftedArray (PrimState m) a) +{-# inline unsafeThawUnliftedArray #-} +unsafeThawUnliftedArray ary = stToPrim $ A.unsafeThawUnliftedArray ary --- | Creates a copy of a portion of an 'UnliftedArray' -cloneUnliftedArray - :: UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> UnliftedArray a -{-# inline cloneUnliftedArray #-} -cloneUnliftedArray src off len = - runUnliftedArray (thawUnliftedArray src off len) +-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it +-- initializes all elements of the array as pointers to the empty array. Attempting +-- to read one of these elements before writing to it is in effect an unsafe +-- coercion from @'UnliftedArray' a@ to the element type. +unsafeNewUnliftedArray + :: PrimMonad m + => Int -- ^ size + -> m (MutableUnliftedArray (PrimState m) a) +{-# inline unsafeNewUnliftedArray #-} +unsafeNewUnliftedArray len = stToPrim $ A.unsafeNewUnliftedArray len -- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of -- another mutable array. @@ -295,170 +195,4 @@ -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) {-# inline cloneMutableUnliftedArray #-} -cloneMutableUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - return dst - -emptyUnliftedArray :: UnliftedArray a -emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0) -{-# NOINLINE emptyUnliftedArray #-} - -singletonUnliftedArray :: PrimUnlifted a => a -> UnliftedArray a -{-# INLINE singletonUnliftedArray #-} -singletonUnliftedArray x = runUnliftedArray $ do - dst <- unsafeNewUnliftedArray 1 - writeUnliftedArray dst 0 x - pure dst - -concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a -{-# INLINE concatUnliftedArray #-} -concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do - copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x) - copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y) - -foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -{-# INLINE foldrUnliftedArray #-} -foldrUnliftedArray f z arr = go 0 - where - !sz = sizeofUnliftedArray arr - go !i - | sz > i = f (indexUnliftedArray arr i) (go (i+1)) - | otherwise = z - --- | Strict right-associated fold over the elements of an 'UnliftedArray. -{-# INLINE foldrUnliftedArray' #-} -foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0 - where - go !i !acc - | i < 0 = acc - | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc) - --- | Lazy left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray #-} -foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1) - where - go !i - | i < 0 = z - | otherwise = f (go (i - 1)) (indexUnliftedArray arr i) - --- | Strict left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray' #-} -foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray' f z0 arr = go 0 z0 - where - !sz = sizeofUnliftedArray arr - go !i !acc - | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i)) - | otherwise = acc - --- | Strict effectful left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArrayM' #-} -foldlUnliftedArrayM' :: (PrimUnlifted a, Monad m) - => (b -> a -> m b) -> b -> UnliftedArray a -> m b -foldlUnliftedArrayM' f z0 arr = go 0 z0 - where - !sz = sizeofUnliftedArray arr - go !i !acc - | i < sz = f acc (indexUnliftedArray arr i) >>= go (i + 1) - | otherwise = pure acc - --- | Effectfully traverse the elements of an 'UnliftedArray', discarding --- the resulting values. -{-# INLINE traverseUnliftedArray_ #-} -traverseUnliftedArray_ :: (PrimUnlifted a, Applicative m) - => (a -> m b) -> UnliftedArray a -> m () -traverseUnliftedArray_ f arr = go 0 - where - !sz = sizeofUnliftedArray arr - go !i - | i < sz = f (indexUnliftedArray arr i) *> go (i + 1) - | otherwise = pure () - --- | Effectful indexed traversal of the elements of an 'UnliftedArray', --- discarding the resulting values. -{-# INLINE itraverseUnliftedArray_ #-} -itraverseUnliftedArray_ :: (PrimUnlifted a, Applicative m) - => (Int -> a -> m b) -> UnliftedArray a -> m () -itraverseUnliftedArray_ f arr = go 0 - where - !sz = sizeofUnliftedArray arr - go !i - | i < sz = f i (indexUnliftedArray arr i) *> go (i + 1) - | otherwise = pure () - --- | Map over the elements of an 'UnliftedArray'. -{-# INLINE mapUnliftedArray #-} -mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) - => (a -> b) - -> UnliftedArray a - -> UnliftedArray b -mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do - let go !ix = if ix < sz - then do - let b = f (indexUnliftedArray arr ix) - writeUnliftedArray marr ix b - go (ix + 1) - else return () - go 0 - where - !sz = sizeofUnliftedArray arr - --- | Convert the unlifted array to a list. -{-# INLINE unliftedArrayToList #-} -unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a] -unliftedArrayToList xs = Exts.build (\c n -> foldrUnliftedArray c n xs) - -unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a -unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs - -unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a -unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where - run :: forall s. MutableUnliftedArray s a -> ST s () - run arr = do - let go :: [a] -> Int -> ST s () - go [] !ix = if ix == len - -- The size check is mandatory since failure to initialize all elements - -- introduces the possibility of a segfault happening when someone attempts - -- to read the unitialized element. See the docs for unsafeNewUnliftedArray. - then return () - else die "unliftedArrayFromListN" "list length less than specified size" - go (a : as) !ix = if ix < len - then do - writeUnliftedArray arr ix a - go as (ix + 1) - else die "unliftedArrayFromListN" "list length greater than specified size" - go vs 0 - -instance PrimUnlifted a => Exts.IsList (UnliftedArray a) where - type Item (UnliftedArray a) = a - fromList = unliftedArrayFromList - fromListN = unliftedArrayFromListN - toList = unliftedArrayToList - -instance PrimUnlifted a => Semigroup (UnliftedArray a) where - (<>) = concatUnliftedArray - -instance PrimUnlifted a => Monoid (UnliftedArray a) where - mempty = emptyUnliftedArray - -instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where - showsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofUnliftedArray a) . showString " " - . shows (unliftedArrayToList a) - -instance Eq (MutableUnliftedArray s a) where - (==) = sameMutableUnliftedArray - -instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where - aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 - && loop (sizeofUnliftedArray aa1 - 1) - where - loop i - | i < 0 = True - | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem +cloneMutableUnliftedArray mary off len = stToPrim $ A.cloneMutableUnliftedArray mary off len diff --git a/src/Data/Primitive/Unlifted/Array/Primops.hs b/src/Data/Primitive/Unlifted/Array/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Array/Primops.hs @@ -0,0 +1,185 @@ +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} +{-# language UnliftedNewtypes #-} +{-# language KindSignatures #-} +{-# language StandaloneKindSignatures #-} +{-# language ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language UnliftedDatatypes #-} + +-- Oh what a mess this is! See UnsafeCoercions.md for an explanation +-- of the hodgepodge in this module. + +-- | +-- Primitive types representing unlifted arrays and the +-- primops for manipulating them. +module Data.Primitive.Unlifted.Array.Primops + ( -- * Types + UnliftedArray#(..) + , MutableUnliftedArray#(..) + + -- * Operations + , newUnliftedArray# + , unsafeNewUnliftedArray# + , emptyUnliftedArray# + , sameMutableUnliftedArray# + , readUnliftedArray# + , writeUnliftedArray# + , sizeofUnliftedArray# + , sizeofMutableUnliftedArray# + , indexUnliftedArray# + , unsafeFreezeUnliftedArray# + , unsafeThawUnliftedArray# + , copyUnliftedArray# + , copyMutableUnliftedArray# + , cloneUnliftedArray# + , cloneMutableUnliftedArray# + , freezeUnliftedArray# + , thawUnliftedArray# + , casUnliftedArray# + ) where + +import Data.Coerce (coerce) +import GHC.Exts ( Int#, State#, Array#, MutableArray# ) +import qualified GHC.Exts as Exts + +import Data.Primitive.Unlifted.Type +import Unsafe.Coerce (unsafeCoerceUnlifted) + +newtype UnliftedArray# (a :: UnliftedType) = UnliftedArray# (Array# a) +type role UnliftedArray# representational + +newtype MutableUnliftedArray# s (a :: UnliftedType) = MutableUnliftedArray# (MutableArray# s a) +type role MutableUnliftedArray# nominal representational + +newUnliftedArray# :: Int# -> a -> State# s -> (# State# s, MutableUnliftedArray# s a #) +newUnliftedArray# sz a s = coerce (Exts.newArray# sz a s) +{-# INLINE newUnliftedArray# #-} + +-- | Create a 'MutableUnliftedArray#' whose entries contain some unspecified +-- static value. This may be more convenient than 'newUnliftedArray#' if there +-- is no value on hand with which to initialize the array. Each entry must be +-- initialized before being read and used. This condition is not checked. +unsafeNewUnliftedArray# :: Int# -> State# s -> (# State# s, MutableUnliftedArray# s a #) +unsafeNewUnliftedArray# sz s + | (# s', mary #) <- Exts.newArray# sz (unsafeCoerceUnlifted Nonsense) s + = (# s', MutableUnliftedArray# mary #) +{-# INLINE unsafeNewUnliftedArray# #-} + +type Nonsense :: UnliftedType +data Nonsense = Nonsense + +-- This represents a *statically allocated* value, preferably in a *read-only* +-- segment of memory. +-- +-- Why do we bother to noDuplicate#? It generally doesn't much *matter* if +-- different threads have different global empty arrays. However, for +-- performance testing purposes, a user may well want to check whether the +-- empty arrays they expect to be the global ones really are. Such a test +-- is only possible if there's just *one* array to test against. The overhead +-- of the once-ever noDuplicate# call is sure to be trivial anyway. +empty_unlifted_array :: ULA a +empty_unlifted_array = ULA + (Exts.runRW# $ \s -> + case Exts.noDuplicate# s of { s' -> + case unsafeNewUnliftedArray# 0# s' of { (# s'', mary #) -> + case unsafeFreezeUnliftedArray# mary s'' of { (# _, ary #) -> + ary }}}) +{-# NOINLINE empty_unlifted_array #-} + +data ULA a = ULA (UnliftedArray# a) + +-- | Warning: Applying 'unsafeThawUnliftedArray#' to the array produced by +-- this function will make demons come out of your nose. +emptyUnliftedArray# :: (##) -> UnliftedArray# a +-- We make this primitive because it's the easiest way to get a +-- *shared* primitive unlifted array. +-- +-- Why the stern warning above? GHC does not currently support resizing 'Array#', +-- and does not really meaningfully support *growing* arrays of any type. If, +-- however, that ever changes, growing the globally shared empty array would be +-- pretty disastrous. +emptyUnliftedArray# (##) = case empty_unlifted_array of + ULA ary -> ary +{-# INLINE emptyUnliftedArray# #-} + +sameMutableUnliftedArray# :: MutableUnliftedArray# s a -> MutableUnliftedArray# s a -> Int# +sameMutableUnliftedArray# (MutableUnliftedArray# ar1) (MutableUnliftedArray# ar2) + = Exts.reallyUnsafePtrEquality# ar1 ar2 +{-# INLINE sameMutableUnliftedArray# #-} + +readUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> State# s -> (# State# s, a #) +readUnliftedArray# (MutableUnliftedArray# mary) i s + = coerce (Exts.readArray# mary i s) +{-# INLINE readUnliftedArray# #-} + +writeUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> a -> State# s -> State# s +writeUnliftedArray# (MutableUnliftedArray# mary) i a s + = Exts.writeArray# mary i a s +{-# INLINE writeUnliftedArray# #-} + +sizeofUnliftedArray# :: UnliftedArray# a -> Int# +sizeofUnliftedArray# (UnliftedArray# ary) = Exts.sizeofArray# ary +{-# INLINE sizeofUnliftedArray# #-} + +sizeofMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# +sizeofMutableUnliftedArray# (MutableUnliftedArray# mary) + = Exts.sizeofMutableArray# mary +{-# INLINE sizeofMutableUnliftedArray# #-} + +indexUnliftedArray# :: UnliftedArray# a -> Int# -> a +indexUnliftedArray# (UnliftedArray# ary) i + = case Exts.indexArray# ary i of (# a #) -> a +{-# INLINE indexUnliftedArray# #-} + +unsafeFreezeUnliftedArray# :: MutableUnliftedArray# s a -> State# s -> (# State# s, UnliftedArray# a #) +unsafeFreezeUnliftedArray# (MutableUnliftedArray# mary) s + = case Exts.unsafeFreezeArray# mary s of + (# s', ary #) -> (# s', UnliftedArray# ary #) +{-# INLINE unsafeFreezeUnliftedArray# #-} + +unsafeThawUnliftedArray# :: UnliftedArray# a -> State# s -> (# State# s, MutableUnliftedArray# s a #) +unsafeThawUnliftedArray# (UnliftedArray# ary) s + = case Exts.unsafeThawArray# ary s of + (# s', mary #) -> (# s', MutableUnliftedArray# mary #) +{-# INLINE unsafeThawUnliftedArray# #-} + +copyUnliftedArray# :: UnliftedArray# a -> Int# -> MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s +copyUnliftedArray# (UnliftedArray# ary) i1 (MutableUnliftedArray# mary) i2 n s + = Exts.copyArray# ary i1 mary i2 n s +{-# INLINE copyUnliftedArray# #-} + +copyMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s +copyMutableUnliftedArray# (MutableUnliftedArray# mary1) i1 (MutableUnliftedArray# mary2) i2 n s + = Exts.copyMutableArray# mary1 i1 mary2 i2 n s +{-# INLINE copyMutableUnliftedArray# #-} + +cloneUnliftedArray# :: UnliftedArray# a -> Int# -> Int# -> UnliftedArray# a +cloneUnliftedArray# (UnliftedArray# ary) i n + = UnliftedArray# (Exts.cloneArray# ary i n) +{-# INLINE cloneUnliftedArray# #-} + +cloneMutableUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> Int# -> State# s + -> (# State# s, MutableUnliftedArray# s a #) +cloneMutableUnliftedArray# (MutableUnliftedArray# mary) i n s + = case Exts.cloneMutableArray# mary i n s of + (# s', mary' #) -> (# s', MutableUnliftedArray# mary' #) +{-# INLINE cloneMutableUnliftedArray# #-} + +freezeUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> Int# -> State# s -> (# State# s, UnliftedArray# a #) +freezeUnliftedArray# (MutableUnliftedArray# mary) i n s + = case Exts.freezeArray# mary i n s of + (# s', ary #) -> (# s', UnliftedArray# ary #) +{-# INLINE freezeUnliftedArray# #-} + +thawUnliftedArray# :: UnliftedArray# a -> Int# -> Int# -> State# s -> (# State# s, MutableUnliftedArray# s a #) +thawUnliftedArray# (UnliftedArray# ary) i n s + = case Exts.thawArray# ary i n s of + (# s', mary #) -> (# s', MutableUnliftedArray# mary #) +{-# INLINE thawUnliftedArray# #-} + +casUnliftedArray# :: MutableUnliftedArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) +casUnliftedArray# (MutableUnliftedArray# mary) i x y s + = coerce (Exts.casArray# mary i x y s) +{-# INLINE casUnliftedArray# #-} diff --git a/src/Data/Primitive/Unlifted/Array/ST.hs b/src/Data/Primitive/Unlifted/Array/ST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Array/ST.hs @@ -0,0 +1,545 @@ +{-# language BangPatterns #-} +{-# language MagicHash #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} + +-- | +-- A version of the 'Data.Primitive.Unlifted.Array' interface +-- specialized to 'ST'. This is intended primarily so library +-- developers can easily check whether the basic operations are +-- unboxed properly, but its more constrained type signatures +-- also offer somewhat better type inference where applicable. +module Data.Primitive.Unlifted.Array.ST + ( -- * Types + UnliftedArray_(..) + , UnliftedArray + , MutableUnliftedArray_(..) + , MutableUnliftedArray + -- * Operations + , newUnliftedArray + , unsafeNewUnliftedArray + , sizeofUnliftedArray + , sizeofMutableUnliftedArray + , sameMutableUnliftedArray + , writeUnliftedArray + , readUnliftedArray + , indexUnliftedArray + , unsafeFreezeUnliftedArray + , freezeUnliftedArray + , thawUnliftedArray + , unsafeThawUnliftedArray + , setUnliftedArray + , copyUnliftedArray + , copyMutableUnliftedArray + , cloneUnliftedArray + , cloneMutableUnliftedArray + , emptyUnliftedArray + , singletonUnliftedArray + , runUnliftedArray + , dupableRunUnliftedArray + -- * List Conversion + , unliftedArrayToList + , unliftedArrayFromList + , unliftedArrayFromListN + -- * Folding + , foldrUnliftedArray + , foldrUnliftedArray' + , foldlUnliftedArray + , foldlUnliftedArray' + , foldlUnliftedArrayM' + -- * Traversals + , traverseUnliftedArray_ + , itraverseUnliftedArray_ + -- * Mapping + , mapUnliftedArray + ) where + +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import Data.Primitive.Unlifted.Array.Primops +import GHC.Exts (Int(I#),State#) +import GHC.ST (ST (..)) + +import qualified Data.List as L +import qualified GHC.Exts as Exts + +-- | Using a specialized copy of primitive_ here makes the Core a little +-- easier to read by eliminating unnecessary PrimState coercions. +primitive_ :: (State# s -> State# s) -> ST s () +{-# INLINE primitive_ #-} +primitive_ m = ST (\s -> (# m s, () #)) + +-- | An @UnliftedArray_ a unlifted_a@ represents an array of values of a +-- lifted type @a@ that wrap values of an unlifted type @unlifted_a@. +-- It is expected that @unlifted_a ~ Unlifted a@, but imposing that constraint +-- here would force the type roles to @nominal@, which is often undesirable +-- when arrays are used as components of larger datatypes. +data UnliftedArray_ unlifted_a a + = UnliftedArray (UnliftedArray# unlifted_a) +type role UnliftedArray_ representational phantom + +-- | A type synonym for an 'UnliftedArray_' containing lifted values of +-- a particular type. As a general rule, this type synonym should not be used in +-- class instances—use 'UnliftedArray_' with an equality constraint instead. +-- It also should not be used when defining newtypes or datatypes, unless those +-- will have restrictive type roles regardless—use 'UnliftedArray_' instead. +type UnliftedArray a = UnliftedArray_ (Unlifted a) a + +-- | A mutable version of 'UnliftedArray_'. +data MutableUnliftedArray_ unlifted_a s a + = MutableUnliftedArray (MutableUnliftedArray# s unlifted_a) +type role MutableUnliftedArray_ representational nominal phantom + +-- | A mutable version of 'MutableUnliftedArray'. +type MutableUnliftedArray s a = MutableUnliftedArray_ (Unlifted a) s a + +instance unlifted_a ~ Unlifted a => PrimUnlifted (UnliftedArray_ unlifted_a a) where + type Unlifted (UnliftedArray_ unlifted_a _) = UnliftedArray# unlifted_a + toUnlifted# (UnliftedArray a) = a + fromUnlifted# x = UnliftedArray x + +instance unlifted_a ~ Unlifted a => PrimUnlifted (MutableUnliftedArray_ unlifted_a s a) where + type Unlifted (MutableUnliftedArray_ unlifted_a s _) = MutableUnliftedArray# s unlifted_a + toUnlifted# (MutableUnliftedArray a) = a + fromUnlifted# x = MutableUnliftedArray x + +-- | Creates a new 'MutableUnliftedArray' with the specified value as initial +-- contents. +newUnliftedArray + :: PrimUnlifted a + => Int -- ^ size + -> a -- ^ initial value + -> ST s (MutableUnliftedArray s a) +newUnliftedArray (I# len) v = ST $ \s -> case newUnliftedArray# len (toUnlifted# v) s of + (# s', ma #) -> (# s', MutableUnliftedArray ma #) +{-# inline newUnliftedArray #-} + +setUnliftedArray + :: PrimUnlifted a + => MutableUnliftedArray s a -- ^ destination + -> a -- ^ value to fill with + -> Int -- ^ offset + -> Int -- ^ length + -> ST s () +{-# inline setUnliftedArray #-} +setUnliftedArray mua v off len = loop (len + off - 1) + where + loop i + | i < off = pure () + | otherwise = writeUnliftedArray mua i v *> loop (i-1) + +-- | Yields the length of an 'UnliftedArray'. +sizeofUnliftedArray :: UnliftedArray e -> Int +{-# inline sizeofUnliftedArray #-} +sizeofUnliftedArray (UnliftedArray ar) = I# (sizeofUnliftedArray# ar) + +-- | Yields the length of a 'MutableUnliftedArray'. +sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int +{-# inline sizeofMutableUnliftedArray #-} +sizeofMutableUnliftedArray (MutableUnliftedArray maa#) + = I# (sizeofMutableUnliftedArray# maa#) + +writeUnliftedArray :: PrimUnlifted a + => MutableUnliftedArray s a + -> Int + -> a + -> ST s () +{-# inline writeUnliftedArray #-} +writeUnliftedArray (MutableUnliftedArray arr) (I# ix) a = + primitive_ (writeUnliftedArray# arr ix (toUnlifted# a)) + +readUnliftedArray :: PrimUnlifted a + => MutableUnliftedArray s a + -> Int + -> ST s a +{-# inline readUnliftedArray #-} +readUnliftedArray (MutableUnliftedArray arr) (I# ix) = + ST $ \s -> case readUnliftedArray# arr ix s of + (# s', a #) -> (# s', fromUnlifted# a #) + +indexUnliftedArray :: PrimUnlifted a + => UnliftedArray a + -> Int + -> a +{-# inline indexUnliftedArray #-} +indexUnliftedArray (UnliftedArray arr) (I# ix) = + fromUnlifted# (indexUnliftedArray# arr ix) + +-- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply +-- marks the array as frozen in place, so it should only be used when no further +-- modifications to the mutable array will be performed. +unsafeFreezeUnliftedArray + :: MutableUnliftedArray s a + -> ST s (UnliftedArray a) +unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) + = ST $ \s -> case unsafeFreezeUnliftedArray# maa# s of + (# s', aa# #) -> (# s', UnliftedArray aa# #) +{-# inline unsafeFreezeUnliftedArray #-} + +-- | Determines whether two 'MutableUnliftedArray' values are the same. This is +-- object/pointer identity, not based on the contents. +sameMutableUnliftedArray + :: MutableUnliftedArray_ unlifted_a s a + -> MutableUnliftedArray_ unlifted_a s a + -> Bool +sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) + = Exts.isTrue# (sameMutableUnliftedArray# maa1# maa2#) +{-# inline sameMutableUnliftedArray #-} + +-- | Copies the contents of an immutable array into a mutable array. +copyUnliftedArray + :: MutableUnliftedArray s a -- ^ destination + -> Int -- ^ offset into destination + -> UnliftedArray a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> ST s () +{-# inline copyUnliftedArray #-} +copyUnliftedArray + (MutableUnliftedArray dst) (I# doff) + (UnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copyUnliftedArray# src soff dst doff ln + +-- | Copies the contents of one mutable array into another. +copyMutableUnliftedArray + :: MutableUnliftedArray s a -- ^ destination + -> Int -- ^ offset into destination + -> MutableUnliftedArray s a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> ST s () +{-# inline copyMutableUnliftedArray #-} +copyMutableUnliftedArray + (MutableUnliftedArray dst) (I# doff) + (MutableUnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copyMutableUnliftedArray# src soff dst doff ln + +-- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. +-- This operation is safe, in that it copies the frozen portion, and the +-- existing mutable array may still be used afterward. +freezeUnliftedArray + :: MutableUnliftedArray s a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (UnliftedArray a) +freezeUnliftedArray (MutableUnliftedArray mary) (I# off) (I# len) = + ST $ \s -> case freezeUnliftedArray# mary off len s of + (# s', ary #) -> (# s', UnliftedArray ary #) +{-# inline freezeUnliftedArray #-} + +-- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. +-- This copies the thawed portion, so mutations will not affect the original +-- array. +thawUnliftedArray + :: UnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (MutableUnliftedArray s a) +{-# inline thawUnliftedArray #-} +thawUnliftedArray (UnliftedArray ary) (I# off) (I# len) = + ST $ \s -> case thawUnliftedArray# ary off len s of + (# s', mary #) -> (# s', MutableUnliftedArray mary #) + +-- | Thaws an 'UnliftedArray', yielding a 'MutableUnliftedArray'. This +-- does not make a copy. +unsafeThawUnliftedArray + :: UnliftedArray a -- ^ source + -> ST s (MutableUnliftedArray s a) +{-# inline unsafeThawUnliftedArray #-} +unsafeThawUnliftedArray (UnliftedArray ary) = + ST $ \s -> case unsafeThawUnliftedArray# ary s of + (# s', mary #) -> (# s', MutableUnliftedArray mary #) + +-- | Execute a stateful computation and freeze the resulting array. +runUnliftedArray + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray a +{-# INLINE runUnliftedArray #-} +-- This is what we'd like to write, but GHC does not yet +-- produce properly unboxed code when we do +-- runUnliftedArray m = runST $ noDuplicate >> m >>= unsafeFreezeUnliftedArray +runUnliftedArray m = UnliftedArray (runUnliftedArray# m) + +runUnliftedArray# + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray# (Unlifted a) +runUnliftedArray# m = case Exts.runRW# $ \s0 -> + case Exts.noDuplicate# s0 of { s -> + case unST m s of { (# s', MutableUnliftedArray mary# #) -> + unsafeFreezeUnliftedArray# mary# s'}} of (# _, ary# #) -> ary# +{-# INLINE runUnliftedArray# #-} + +-- | Execute a stateful computation and freeze the resulting array. +-- It is possible, but unlikely, that the computation will be run +-- multiple times in multiple threads. +dupableRunUnliftedArray + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray a +{-# INLINE dupableRunUnliftedArray #-} +-- This is what we'd like to write, but GHC does not yet +-- produce properly unboxed code when we do +-- runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray +dupableRunUnliftedArray m = UnliftedArray (dupableRunUnliftedArray# m) + +dupableRunUnliftedArray# + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray# (Unlifted a) +dupableRunUnliftedArray# m = case Exts.runRW# $ \s -> + case unST m s of { (# s', MutableUnliftedArray mary# #) -> + unsafeFreezeUnliftedArray# mary# s'} of (# _, ary# #) -> ary# +{-# INLINE dupableRunUnliftedArray# #-} + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (ST f) = f + +unsafeCreateUnliftedArray + :: Int + -> (forall s. MutableUnliftedArray s a -> ST s ()) + -> UnliftedArray a +unsafeCreateUnliftedArray !n f = runUnliftedArray $ do + mary <- unsafeNewUnliftedArray n + f mary + pure mary + +-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it +-- initializes all elements of the array as pointers to the empty array. Attempting +-- to read one of these elements before writing to it is in effect an unsafe +-- coercion from @'UnliftedArray' a@ to the element type. +unsafeNewUnliftedArray + :: Int -- ^ size + -> ST s (MutableUnliftedArray s a) +{-# inline unsafeNewUnliftedArray #-} +unsafeNewUnliftedArray (I# i) = ST $ \s -> case unsafeNewUnliftedArray# i s of + (# s', ma #) -> (# s', MutableUnliftedArray ma #) + + +-- | Creates a copy of a portion of an 'UnliftedArray' +cloneUnliftedArray + :: UnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> UnliftedArray a +{-# inline cloneUnliftedArray #-} +cloneUnliftedArray (UnliftedArray ary) (I# off) (I# len) + = UnliftedArray (cloneUnliftedArray# ary off len) + +-- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of +-- another mutable array. +cloneMutableUnliftedArray + :: MutableUnliftedArray s a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (MutableUnliftedArray s a) +{-# inline cloneMutableUnliftedArray #-} +cloneMutableUnliftedArray (MutableUnliftedArray mary) (I# off) (I# len) + = ST $ \s -> case cloneMutableUnliftedArray# mary off len s of + (# s', mary' #) -> (# s', MutableUnliftedArray mary' #) + +emptyUnliftedArray :: UnliftedArray_ unlifted_a a +emptyUnliftedArray = UnliftedArray (emptyUnliftedArray# (##)) + +singletonUnliftedArray :: PrimUnlifted a => a -> UnliftedArray a +{-# INLINE singletonUnliftedArray #-} +singletonUnliftedArray x = dupableRunUnliftedArray $ newUnliftedArray 1 x + +concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a +{-# INLINE concatUnliftedArray #-} +concatUnliftedArray (UnliftedArray a1) (UnliftedArray a2) + = UnliftedArray (concatUnliftedArray# a1 a2) + +-- This junk is to make sure we unbox properly. Inlining this doesn't seem +-- likely to be much of a win ever, and could potentially lead to reboxing, +-- so we NOINLINE. It would be nice to find a prettier way to do this. +concatUnliftedArray# :: UnliftedArray# a -> UnliftedArray# a -> UnliftedArray# a +{-# NOINLINE concatUnliftedArray# #-} +concatUnliftedArray# a1 a2 = + let !sza1 = sizeofUnliftedArray# a1 + in + if Exts.isTrue# (sza1 Exts.==# 0#) + then a2 + else + let !sza2 = sizeofUnliftedArray# a2 + in + if Exts.isTrue# (sza2 Exts.==# 0#) + then a1 + else Exts.runRW# $ \s0 -> + let + finish s = + case unsafeNewUnliftedArray# (sza1 Exts.+# sza2) s of { (# s', ma #) -> + case copyUnliftedArray# a1 0# ma 0# sza1 s' of { s'' -> + case copyUnliftedArray# a2 0# ma sza1 sza2 s'' of { s''' -> + case unsafeFreezeUnliftedArray# ma s''' of + (# _, ar #) -> ar}}} + -- GHC wants to inline this, but I very much doubt it's worth the + -- extra code, considering that it calls multiple out-of-line + -- primops. + {-# NOINLINE finish #-} + in + -- When the final array will be "small", we tolerate the possibility that + -- it could be constructed multiple times in different threads. Currently, + -- "small" means fewer than 1000 elements. This is a totally arbitrary + -- cutoff that has not been tuned whatsoever. + if Exts.isTrue# ((sza1 Exts.+# sza2) Exts.>=# 1000#) + then finish (Exts.noDuplicate# s0) + else finish s0 + +foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b +{-# INLINE foldrUnliftedArray #-} +foldrUnliftedArray f z arr = go 0 + where + !sz = sizeofUnliftedArray arr + go !i + | sz > i = f (indexUnliftedArray arr i) (go (i+1)) + | otherwise = z + +-- | Strict right-associated fold over the elements of an 'UnliftedArray. +{-# INLINE foldrUnliftedArray' #-} +foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b +foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0 + where + go !i !acc + | i < 0 = acc + | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc) + +-- | Lazy left-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldlUnliftedArray #-} +foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b +foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1) + where + go !i + | i < 0 = z + | otherwise = f (go (i - 1)) (indexUnliftedArray arr i) + +-- | Strict left-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldlUnliftedArray' #-} +foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b +foldlUnliftedArray' f z0 arr = go 0 z0 + where + !sz = sizeofUnliftedArray arr + go !i !acc + | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i)) + | otherwise = acc + +-- | Strict effectful left-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldlUnliftedArrayM' #-} +foldlUnliftedArrayM' :: (PrimUnlifted a, Monad m) + => (b -> a -> m b) -> b -> UnliftedArray a -> m b +foldlUnliftedArrayM' f z0 arr = go 0 z0 + where + !sz = sizeofUnliftedArray arr + go !i !acc + | i < sz = f acc (indexUnliftedArray arr i) >>= go (i + 1) + | otherwise = pure acc + +-- | Effectfully traverse the elements of an 'UnliftedArray', discarding +-- the resulting values. +{-# INLINE traverseUnliftedArray_ #-} +traverseUnliftedArray_ :: (PrimUnlifted a, Applicative m) + => (a -> m b) -> UnliftedArray a -> m () +traverseUnliftedArray_ f arr = go 0 + where + !sz = sizeofUnliftedArray arr + go !i + | i < sz = f (indexUnliftedArray arr i) *> go (i + 1) + | otherwise = pure () + +-- | Effectful indexed traversal of the elements of an 'UnliftedArray', +-- discarding the resulting values. +{-# INLINE itraverseUnliftedArray_ #-} +itraverseUnliftedArray_ :: (PrimUnlifted a, Applicative m) + => (Int -> a -> m b) -> UnliftedArray a -> m () +itraverseUnliftedArray_ f arr = go 0 + where + !sz = sizeofUnliftedArray arr + go !i + | i < sz = f i (indexUnliftedArray arr i) *> go (i + 1) + | otherwise = pure () + +-- | Map over the elements of an 'UnliftedArray'. +{-# INLINE mapUnliftedArray #-} +mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) + => (a -> b) + -> UnliftedArray a + -> UnliftedArray b +-- TODO: Do we need unsafeCreateUnliftedArray here, or would it be better +-- to use a hypothetical unsafeDupableCreateUnliftedArray? I don't have +-- much intuition for this. On one hand, if the operation creates a +-- bunch of expensive objects to stick in the array, then we really don't want +-- to duplicate that work. On the other hand, it's likely that creating +-- a bunch of expensive objects will also allocate a bunch of memory, which +-- will likely trigger garbage collection that (as I understand it) will +-- notice that one thunk is being evaluated twice and deduplicate. On the +-- other other hand, I don't think there's any guarantee that the thread that wins will be +-- the one that's further along, so maybe the noDuplicate is for the best. +mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do + let go !ix = if ix < sz + then do + let b = f (indexUnliftedArray arr ix) + writeUnliftedArray marr ix b + go (ix + 1) + else return () + go 0 + where + !sz = sizeofUnliftedArray arr + +-- | Convert the unlifted array to a list. +{-# INLINE unliftedArrayToList #-} +unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a] +unliftedArrayToList xs = Exts.build (\c n -> foldrUnliftedArray c n xs) + +unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a +unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs + +unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a +unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where + run :: forall s. MutableUnliftedArray s a -> ST s () + run arr = do + let go :: [a] -> Int -> ST s () + go [] !ix = if ix == len + -- The size check is mandatory since failure to initialize all elements + -- introduces the possibility of a segfault happening when someone attempts + -- to read the unitialized element. See the docs for unsafeNewUnliftedArray. + then return () + else die "unliftedArrayFromListN" "list length less than specified size" + go (a : as) !ix = if ix < len + then do + writeUnliftedArray arr ix a + go as (ix + 1) + else die "unliftedArrayFromListN" "list length greater than specified size" + go vs 0 + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) + => Exts.IsList (UnliftedArray_ unlifted_a a) where + type Item (UnliftedArray_ _ a) = a + fromList = unliftedArrayFromList + fromListN = unliftedArrayFromListN + toList = unliftedArrayToList + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) + => Semigroup (UnliftedArray_ unlifted_a a) where + (<>) = concatUnliftedArray + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) => Monoid (UnliftedArray_ unlifted_a a) where + mempty = emptyUnliftedArray + +instance (Show a, PrimUnlifted a, unlifted_a ~ Unlifted a) => Show (UnliftedArray_ unlifted_a a) where + showsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofUnliftedArray a) . showString " " + . shows (unliftedArrayToList a) + +instance unlifted_a ~ Unlifted a => Eq (MutableUnliftedArray_ unlifted_a s a) where + (==) = sameMutableUnliftedArray + +instance (Eq a, PrimUnlifted a, unlifted_a ~ Unlifted a) => Eq (UnliftedArray_ unlifted_a a) where + aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 + && loop (sizeofUnliftedArray aa1 - 1) + where + loop i + | i < 0 = True + | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.UnliftedArray.ST." ++ fun ++ ": " ++ problem diff --git a/src/Data/Primitive/Unlifted/Box.hs b/src/Data/Primitive/Unlifted/Box.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Box.hs @@ -0,0 +1,48 @@ +{-# language KindSignatures #-} +{-# language TypeFamilies #-} +{-# language MagicHash #-} +{-# language DataKinds #-} + +-- | Traditionally, there were only a few basic unlifted types available in +-- GHC, all of them primitive. Now, with the @UnliftedNewtypes@ and +-- @UnliftedDatatypes@ extensions, users are free to create as many as they +-- like. However, many essential facilities, like the 'Monad' class, still work +-- only with lifted types, so users must wrap their unlifted types into lifted +-- ones to use those. If the wrapped version of a type is likely to be used +-- heavily on its own, it often makes sense to write a custom wrapper type for +-- it. This module exports a general box for situations where the focus should +-- be on the unlifted type rather than its wrapper. +module Data.Primitive.Unlifted.Box where + +import Data.Primitive.Unlifted.Class +import Data.Primitive.Unlifted.Type + +-- | Turn an arbitrary unlifted type into a lifted one with a 'PrimUnlifted' +-- instance. For example, given +-- +-- @ +-- data UnliftedMaybe a :: UnliftedType where +-- UnliftedNothing :: UnliftedMaybe a +-- UnliftedJust :: a -> UnliftedMaybe a +-- @ +-- +-- we have +-- +-- @ +-- Box (UnliftedMaybe a) :: Type +-- @ +data Box (a :: UnliftedType) = Box# { unBox# :: a } + +instance PrimUnlifted (Box a) where + {-# INLINE toUnlifted# #-} + {-# INLINE fromUnlifted# #-} + type Unlifted (Box a) = a + + toUnlifted# (Box# a) = a + fromUnlifted# a = Box# a + +toBox :: PrimUnlifted a => a -> Box (Unlifted a) +toBox a = Box# (toUnlifted# a) + +fromBox :: PrimUnlifted a => Box (Unlifted a) -> a +fromBox (Box# a) = fromUnlifted# a diff --git a/src/Data/Primitive/Unlifted/Class.hs b/src/Data/Primitive/Unlifted/Class.hs --- a/src/Data/Primitive/Unlifted/Class.hs +++ b/src/Data/Primitive/Unlifted/Class.hs @@ -2,7 +2,6 @@ {-# language UnboxedTuples #-} {-# language TypeFamilies #-} {-# language ScopedTypeVariables #-} -{-# language CPP #-} {-# language DataKinds #-} module Data.Primitive.Unlifted.Class @@ -14,212 +13,121 @@ import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) import Data.Primitive.PrimArray (PrimArray(..),MutablePrimArray(..)) import Data.Primitive.ByteArray (ByteArray(..),MutableByteArray(..)) +import Data.Primitive.Array (Array (..), MutableArray (..)) +import Data.Primitive.SmallArray (SmallArray (..), SmallMutableArray (..)) +import Data.Primitive.MutVar (MutVar (..)) import GHC.MVar (MVar(..)) import GHC.IORef (IORef(..)) import GHC.STRef (STRef(..)) -import GHC.Exts (State#,MutableByteArray#,ByteArray#,Int#) -import GHC.Exts (ArrayArray#,MutableArrayArray#) +import GHC.Weak (Weak(..)) +import GHC.Conc (TVar(..),ThreadId(..)) +import GHC.StableName (StableName(..)) +import GHC.Exts (MutableByteArray#,ByteArray# + ,Array#,MutableArray#,SmallArray#,SmallMutableArray# + ,Weak#,TVar#,ThreadId#,StableName#) import GHC.Exts (MVar#,MutVar#,RealWorld) -import GHC.Exts (TYPE,unsafeCoerce#) import qualified Data.Primitive.MVar as PM import qualified GHC.Exts as Exts --- In GHC 9.2 the UnliftedRep constructor of RuntimeRep was removed --- and replaced with a type synonym -#if __GLASGOW_HASKELL__ >= 902 -import GHC.Exts (UnliftedRep) -#else -import GHC.Exts (RuntimeRep(UnliftedRep)) -type UnliftedRep = 'UnliftedRep -#endif +import Data.Primitive.Unlifted.Type class PrimUnlifted a where - type Unlifted a :: TYPE UnliftedRep + type Unlifted a :: UnliftedType toUnlifted# :: a -> Unlifted a fromUnlifted# :: Unlifted a -> a - writeUnliftedArray# :: - MutableArrayArray# s - -> Int# - -> a - -> State# s - -> State# s - readUnliftedArray# :: - MutableArrayArray# s - -> Int# - -> State# s - -> (# State# s, a #) - indexUnliftedArray# :: - ArrayArray# - -> Int# - -> a +instance PrimUnlifted (Array a) where + type Unlifted (Array a) = Array# a + toUnlifted# (Array a) = a + fromUnlifted# x = Array x + +instance PrimUnlifted (MutableArray s a) where + type Unlifted (MutableArray s a) = MutableArray# s a + toUnlifted# (MutableArray a) = a + fromUnlifted# x = MutableArray x + +instance PrimUnlifted (SmallArray a) where + type Unlifted (SmallArray a) = SmallArray# a + toUnlifted# (SmallArray a) = a + fromUnlifted# x = SmallArray x + +instance PrimUnlifted (SmallMutableArray s a) where + type Unlifted (SmallMutableArray s a) = SmallMutableArray# s a + toUnlifted# (SmallMutableArray a) = a + fromUnlifted# x = SmallMutableArray x + instance PrimUnlifted (PrimArray a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (PrimArray a) = ByteArray# toUnlifted# (PrimArray x) = x fromUnlifted# x = PrimArray x - writeUnliftedArray# a i (PrimArray x) = Exts.writeByteArrayArray# a i x - readUnliftedArray# a i s0 = case Exts.readByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, PrimArray x #) - indexUnliftedArray# a i = PrimArray (Exts.indexByteArrayArray# a i) instance PrimUnlifted ByteArray where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted ByteArray = ByteArray# toUnlifted# (ByteArray x) = x fromUnlifted# x = ByteArray x - writeUnliftedArray# a i (ByteArray x) = Exts.writeByteArrayArray# a i x - readUnliftedArray# a i s0 = case Exts.readByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, ByteArray x #) - indexUnliftedArray# a i = ByteArray (Exts.indexByteArrayArray# a i) instance PrimUnlifted ShortByteString where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted ShortByteString = ByteArray# toUnlifted# (SBS x) = x fromUnlifted# x = SBS x - writeUnliftedArray# a i (SBS x) = Exts.writeByteArrayArray# a i x - readUnliftedArray# a i s0 = case Exts.readByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, SBS x #) - indexUnliftedArray# a i = SBS (Exts.indexByteArrayArray# a i) instance PrimUnlifted ShortText where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted ShortText = ByteArray# toUnlifted# t = case toShortByteString t of { SBS x -> x } fromUnlifted# x = fromShortByteStringUnsafe (SBS x) - writeUnliftedArray# a i t = case toShortByteString t of - SBS x -> Exts.writeByteArrayArray# a i x - readUnliftedArray# a i s0 = case Exts.readByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, fromShortByteStringUnsafe (SBS x) #) - indexUnliftedArray# a i = fromShortByteStringUnsafe (SBS (Exts.indexByteArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of --- indexUnliftedArray#. This does not lead to corruption FFI codegen --- since ByteArray# and MutableByteArray# have the same FFI offset --- applied by add_shim. --- This also uses unsafeCoerce# to relax the constraints on the --- state token. The primitives in GHC.Prim are too restrictive. instance PrimUnlifted (MutableByteArray s) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (MutableByteArray s) = MutableByteArray# s toUnlifted# (MutableByteArray x) = x fromUnlifted# x = MutableByteArray x - writeUnliftedArray# a i (MutableByteArray x) = - Exts.writeMutableByteArrayArray# a i (retoken x) - readUnliftedArray# a i s0 = case Exts.readMutableByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, MutableByteArray (retoken x) #) - indexUnliftedArray# a i = MutableByteArray (baToMba (Exts.indexByteArrayArray# a i)) --- See the note on the PrimUnlifted instance for MutableByteArray. --- The same uses of unsafeCoerce# happen here. instance PrimUnlifted (MutablePrimArray s a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (MutablePrimArray s a) = MutableByteArray# s toUnlifted# (MutablePrimArray x) = x fromUnlifted# x = MutablePrimArray x - writeUnliftedArray# a i (MutablePrimArray x) = - Exts.writeMutableByteArrayArray# a i (retoken x) - readUnliftedArray# a i s0 = case Exts.readMutableByteArrayArray# a i s0 of - (# s1, x #) -> (# s1, MutablePrimArray (retoken x) #) - indexUnliftedArray# a i = MutablePrimArray (baToMba (Exts.indexByteArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of all of its --- methods. This does not lead to corruption FFI codegen since ArrayArray# --- and MVar# have the same FFI offset applied by add_shim. However, in --- GHC 8.10, the offset of ArrayArray# changes. Consequently, this library --- cannot build with GHC 8.10. instance PrimUnlifted (PM.MVar s a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (PM.MVar s a) = MVar# s a toUnlifted# (PM.MVar x) = x fromUnlifted# x = PM.MVar x - writeUnliftedArray# a i (PM.MVar x) = - Exts.writeArrayArrayArray# a i (mvarToArrArr x) - readUnliftedArray# a i s0 = case Exts.readArrayArrayArray# a i s0 of - (# s1, x #) -> (# s1, PM.MVar (arrArrToMVar x) #) - indexUnliftedArray# a i = PM.MVar (arrArrToMVar (Exts.indexArrayArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of all of its --- methods. See the note for the PrimUnlifted instance of --- Data.Primitive.MVar.MVar. instance PrimUnlifted (MVar a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (MVar a) = MVar# RealWorld a toUnlifted# (MVar x) = x fromUnlifted# x = MVar x - writeUnliftedArray# a i (MVar x) = - Exts.writeArrayArrayArray# a i (mvarToArrArr x) - readUnliftedArray# a i s0 = case Exts.readArrayArrayArray# a i s0 of - (# s1, x #) -> (# s1, MVar (arrArrToMVar x) #) - indexUnliftedArray# a i = MVar (arrArrToMVar (Exts.indexArrayArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of all of its --- methods. This does not lead to corruption FFI codegen since ArrayArray# --- and MutVar# have the same FFI offset applied by add_shim. +instance PrimUnlifted (MutVar s a) where + type Unlifted (MutVar s a) = MutVar# s a + toUnlifted# (MutVar x) = x + fromUnlifted# x = MutVar x + instance PrimUnlifted (STRef s a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (STRef s a) = MutVar# s a toUnlifted# (STRef x) = x fromUnlifted# x = STRef x - writeUnliftedArray# a i (STRef x) = - Exts.writeArrayArrayArray# a i (mutVarToArrArr x) - readUnliftedArray# a i s0 = case Exts.readArrayArrayArray# a i s0 of - (# s1, x #) -> (# s1, STRef (arrArrToMutVar x) #) - indexUnliftedArray# a i = - STRef (arrArrToMutVar (Exts.indexArrayArrayArray# a i)) instance PrimUnlifted (IORef a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} type Unlifted (IORef a) = MutVar# RealWorld a toUnlifted# (IORef (STRef x)) = x fromUnlifted# x = IORef (STRef x) - writeUnliftedArray# a i (IORef v) = writeUnliftedArray# a i v - readUnliftedArray# a i s0 = case readUnliftedArray# a i s0 of - (# s1, v #) -> (# s1, IORef v #) - indexUnliftedArray# a i = IORef (indexUnliftedArray# a i) -arrArrToMutVar :: ArrayArray# -> MutVar# s a -{-# inline arrArrToMutVar #-} -arrArrToMutVar = unsafeCoerce# - -mutVarToArrArr :: MutVar# s a -> ArrayArray# -{-# inline mutVarToArrArr #-} -mutVarToArrArr = unsafeCoerce# - -arrArrToMVar :: ArrayArray# -> MVar# s a -{-# inline arrArrToMVar #-} -arrArrToMVar = unsafeCoerce# +instance PrimUnlifted (Weak a) where + type Unlifted (Weak a) = Weak# a + toUnlifted# (Weak w) = w + fromUnlifted# w = Weak w -mvarToArrArr :: MVar# s a -> ArrayArray# -{-# inline mvarToArrArr #-} -mvarToArrArr = unsafeCoerce# +instance PrimUnlifted (TVar a) where + type Unlifted (TVar a) = TVar# Exts.RealWorld a + toUnlifted# (TVar t) = t + fromUnlifted# t = TVar t -baToMba :: ByteArray# -> MutableByteArray# s -{-# inline baToMba #-} -baToMba = unsafeCoerce# +instance PrimUnlifted ThreadId where + type Unlifted ThreadId = ThreadId# + toUnlifted# (ThreadId tid) = tid + fromUnlifted# tid = ThreadId tid -retoken :: MutableByteArray# s -> MutableByteArray# r -{-# inline retoken #-} -retoken = unsafeCoerce# +instance PrimUnlifted (StableName a) where + type Unlifted (StableName a) = StableName# a + toUnlifted# (StableName sn) = sn + fromUnlifted# sn = StableName sn diff --git a/src/Data/Primitive/Unlifted/MVar.hs b/src/Data/Primitive/Unlifted/MVar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MVar.hs @@ -0,0 +1,138 @@ +{-# language UnboxedTuples #-} +{-# language UnboxedSums #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language MagicHash #-} +{-# language RankNTypes #-} +{-# language PatternSynonyms #-} +{-# language ViewPatterns #-} +{-# language BangPatterns #-} +{- options_ghc -ddump-simpl #-} + +-- | This module includes all the features of "Control.Concurrent.MVar", except +-- that the functions in "Data.Primitive.Unlifted.Weak" subsume the functionality +-- of @mkWeakMV@ and @addMVarFinalizer@, so we do not include analogues of those +-- functions. +module Data.Primitive.Unlifted.MVar + ( UnliftedMVar_ (..) + , UnliftedMVar + , newUnliftedMVar + , newEmptyUnliftedMVar + , takeUnliftedMVar + , tryTakeUnliftedMVar + , putUnliftedMVar + , tryPutUnliftedMVar + , readUnliftedMVar + , tryReadUnliftedMVar + , isEmptyUnliftedMVar + , swapUnliftedMVar + , withUnliftedMVar + , withUnliftedMVarMasked + , modifyUnliftedMVar + , modifyUnliftedMVar_ + , modifyUnliftedMVarMasked + , modifyUnliftedMVarMasked_ + ) where +import qualified Data.Primitive.Unlifted.MVar.ST as MV +import Data.Primitive.Unlifted.MVar.ST + ( UnliftedMVar_ (..), type UnliftedMVar ) +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import GHC.Exts (RealWorld) +import Control.Monad.Primitive (stToPrim, PrimMonad (..), PrimBase, primToST) + +newUnliftedMVar + :: (PrimUnlifted a, PrimMonad m) + => a -> m (UnliftedMVar (PrimState m) a) +newUnliftedMVar a = stToPrim $ MV.newUnliftedMVar a + +newEmptyUnliftedMVar + :: PrimMonad m + => m (UnliftedMVar (PrimState m) a) +{-# INLINE newEmptyUnliftedMVar #-} +newEmptyUnliftedMVar = stToPrim $ MV.newEmptyUnliftedMVar + +takeUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> m a +{-# INLINE takeUnliftedMVar #-} +takeUnliftedMVar mv = stToPrim $ MV.takeUnliftedMVar mv + +tryTakeUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> m (Maybe a) +{-# INLINE tryTakeUnliftedMVar #-} +tryTakeUnliftedMVar mv = stToPrim $ MV.tryTakeUnliftedMVar mv + +putUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> a -> m () +{-# INLINE putUnliftedMVar #-} +putUnliftedMVar mv a = stToPrim $ MV.putUnliftedMVar mv a + +tryPutUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> a -> m Bool +{-# INLINE tryPutUnliftedMVar #-} +tryPutUnliftedMVar mv a = stToPrim $ MV.tryPutUnliftedMVar mv a + +readUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> m a +{-# INLINE readUnliftedMVar #-} +readUnliftedMVar mv = stToPrim $ MV.readUnliftedMVar mv + +tryReadUnliftedMVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMVar (PrimState m) a -> m (Maybe a) +{-# INLINE tryReadUnliftedMVar #-} +tryReadUnliftedMVar mv = stToPrim $ MV.tryReadUnliftedMVar mv + +isEmptyUnliftedMVar + :: PrimMonad m + => UnliftedMVar (PrimState m) a -> m Bool +{-# INLINE isEmptyUnliftedMVar #-} +isEmptyUnliftedMVar mv = stToPrim $ MV.isEmptyUnliftedMVar mv + +swapUnliftedMVar + :: (PrimMonad m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> a -> m a +{-# INLINE swapUnliftedMVar #-} +swapUnliftedMVar mvar new = stToPrim $ MV.swapUnliftedMVar mvar new + +withUnliftedMVar + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m b) -> m b +{-# INLINE withUnliftedMVar #-} +withUnliftedMVar m f = stToPrim $ MV.withUnliftedMVar m (primToST . f) + +withUnliftedMVarMasked + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m b) -> m b +{-# INLINE withUnliftedMVarMasked #-} +withUnliftedMVarMasked m st = stToPrim $ MV.withUnliftedMVarMasked m (primToST . st) + +modifyUnliftedMVar + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m (a, b)) -> m b +{-# INLINE modifyUnliftedMVar #-} +modifyUnliftedMVar m st = stToPrim $ MV.modifyUnliftedMVar m (primToST . st) + +modifyUnliftedMVar_ + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m a) -> m () +{-# INLINE modifyUnliftedMVar_ #-} +modifyUnliftedMVar_ m st = stToPrim $ MV.modifyUnliftedMVar_ m (primToST . st) + +modifyUnliftedMVarMasked + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m (a, b)) -> m b +{-# INLINE modifyUnliftedMVarMasked #-} +modifyUnliftedMVarMasked m st = stToPrim $ MV.modifyUnliftedMVarMasked m (primToST . st) + +modifyUnliftedMVarMasked_ + :: (PrimBase m, PrimState m ~ RealWorld, PrimUnlifted a) + => UnliftedMVar RealWorld a -> (a -> m a) -> m () +{-# INLINE modifyUnliftedMVarMasked_ #-} +modifyUnliftedMVarMasked_ m st = stToPrim $ MV.modifyUnliftedMVarMasked_ m (primToST . st) diff --git a/src/Data/Primitive/Unlifted/MVar/Primops.hs b/src/Data/Primitive/Unlifted/MVar/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MVar/Primops.hs @@ -0,0 +1,73 @@ +{-# language ScopedTypeVariables #-} +{-# language MagicHash #-} +{-# language KindSignatures #-} +{-# language UnboxedTuples #-} +{-# language UnboxedSums #-} +{-# language UnliftedNewtypes #-} +{-# language RoleAnnotations #-} +{-# language DataKinds #-} + +module Data.Primitive.Unlifted.MVar.Primops + ( UnliftedMVar# + , newUnliftedMVar# + , takeUnliftedMVar# + , tryTakeUnliftedMVar# + , putUnliftedMVar# + , tryPutUnliftedMVar# + , readUnliftedMVar# + , tryReadUnliftedMVar# + , sameUnliftedMVar# + , isEmptyUnliftedMVar# + ) where + +import GHC.Exts (MVar#, State#, Int#, newMVar#, takeMVar#, tryTakeMVar#, putMVar#, tryPutMVar#, readMVar#, tryReadMVar#, reallyUnsafePtrEquality#, isEmptyMVar#) + +import Data.Primitive.Unlifted.Type + +newtype UnliftedMVar# s (a :: UnliftedType) = UnliftedMVar# (MVar# s a) +type role UnliftedMVar# nominal representational + +newUnliftedMVar# :: State# s -> (# State# s, UnliftedMVar# s a #) +{-# INLINE newUnliftedMVar# #-} +newUnliftedMVar# s = case newMVar# s of + (# s', mv #) -> (# s', UnliftedMVar# mv #) + +takeUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, a #) +{-# INLINE takeUnliftedMVar# #-} +takeUnliftedMVar# (UnliftedMVar# mv) s = takeMVar# mv s + +tryTakeUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, (# (##) | a #) #) +{-# INLINE tryTakeUnliftedMVar# #-} +tryTakeUnliftedMVar# (UnliftedMVar# mv) s = + case tryTakeMVar# mv s of + (# s', 0#, _ #) -> (# s', (#(##)| #)#) + (# s', _, a #) -> (# s', (#|a #) #) + +putUnliftedMVar# :: UnliftedMVar# s a -> a -> State# s -> State# s +{-# INLINE putUnliftedMVar# #-} +putUnliftedMVar# (UnliftedMVar# mv) a s = putMVar# mv a s + +tryPutUnliftedMVar# :: UnliftedMVar# s a -> a -> State# s -> (# State# s, Int# #) +{-# INLINE tryPutUnliftedMVar# #-} +tryPutUnliftedMVar# (UnliftedMVar# mv) a s = tryPutMVar# mv a s + +readUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, a #) +{-# INLINE readUnliftedMVar# #-} +readUnliftedMVar# (UnliftedMVar# mv) s = readMVar# mv s + +tryReadUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, (# (##) | a #) #) +{-# INLINE tryReadUnliftedMVar# #-} +tryReadUnliftedMVar# (UnliftedMVar# mv) s = + case tryReadMVar# mv s of + (# s', 0#, _ #) -> (# s', (#(##)| #)#) + (# s', _, a #) -> (# s', (#|a #) #) + +sameUnliftedMVar# :: UnliftedMVar# s a -> UnliftedMVar# s a -> Int# +{-# INLINE sameUnliftedMVar# #-} +sameUnliftedMVar# (UnliftedMVar# mv1) (UnliftedMVar# mv2) + = reallyUnsafePtrEquality# mv1 mv2 + +isEmptyUnliftedMVar# :: UnliftedMVar# s a -> State# s -> (# State# s, Int# #) +{-# INLINE isEmptyUnliftedMVar# #-} +isEmptyUnliftedMVar# (UnliftedMVar# mv) s + = isEmptyMVar# mv s diff --git a/src/Data/Primitive/Unlifted/MVar/ST.hs b/src/Data/Primitive/Unlifted/MVar/ST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MVar/ST.hs @@ -0,0 +1,276 @@ +{-# language UnboxedTuples #-} +{-# language UnboxedSums #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language MagicHash #-} +{-# language RankNTypes #-} +{-# language PatternSynonyms #-} +{-# language ViewPatterns #-} +{-# language BangPatterns #-} +{- options_ghc -ddump-simpl #-} + +-- | This module includes all the features of "Control.Concurrent.MVar", except +-- that the functions in "Data.Primitive.Unlifted.Weak" subsume the functionality +-- of @mkWeakMV@ and @addMVarFinalizer@, so we do not include analogues of those +-- functions. +module Data.Primitive.Unlifted.MVar.ST + ( UnliftedMVar_ (..) + , UnliftedMVar + , newUnliftedMVar + , newEmptyUnliftedMVar + , takeUnliftedMVar + , tryTakeUnliftedMVar + , putUnliftedMVar + , tryPutUnliftedMVar + , readUnliftedMVar + , tryReadUnliftedMVar + , isEmptyUnliftedMVar + , swapUnliftedMVar + , withUnliftedMVar + , withUnliftedMVarMasked + , modifyUnliftedMVar + , modifyUnliftedMVar_ + , modifyUnliftedMVarMasked + , modifyUnliftedMVarMasked_ + ) where +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import Data.Primitive.Unlifted.MVar.Primops +import Data.Primitive.Unlifted.Box +import GHC.Exts (isTrue#, State#, RealWorld) +import GHC.ST (ST (..)) +import GHC.IO (IO (..)) +import qualified Control.Exception as E -- (mask, mask_, onException) +import Control.Monad.Primitive (primToST, stToPrim) +import Data.Coerce (coerce) + +mask :: ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b) -> ST RealWorld b +{-# INLINE mask #-} +mask f = primToST $ E.mask (\restore -> stToPrim $ f (primToST . restore . stToPrim)) + +mask_ :: ST RealWorld a -> ST RealWorld a +{-# INLINE mask_ #-} +mask_ f = mask $ \_ -> f + +primitive_ :: (State# s -> State# s) -> ST s () +{-# INLINE primitive_ #-} +primitive_ f = ST (\s -> (# f s, () #)) + +onException :: forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a +{-# INLINE onException #-} +onException = coerce (E.onException :: IO a -> IO b -> IO a) + +data UnliftedMVar_ s a unlifted_a + = UnliftedMVar (UnliftedMVar# s unlifted_a) +type role UnliftedMVar_ nominal phantom representational + +type UnliftedMVar s a = UnliftedMVar_ s a (Unlifted a) + +instance unlifted_a ~ Unlifted a => PrimUnlifted (UnliftedMVar_ s a unlifted_a) where + {-# INLINE toUnlifted# #-} + {-# INLINE fromUnlifted# #-} + type Unlifted (UnliftedMVar_ s _ unlifted_a) = UnliftedMVar# s unlifted_a + toUnlifted# (UnliftedMVar mv) = mv + fromUnlifted# mv = UnliftedMVar mv + +instance unlifted_a ~ Unlifted a => Eq (UnliftedMVar_ s a unlifted_a) where + {-# INLINE (==) #-} + UnliftedMVar mv1 == UnliftedMVar mv2 + = isTrue# (sameUnliftedMVar# mv1 mv2) + +newUnliftedMVar + :: PrimUnlifted a + => a -> ST s (UnliftedMVar s a) +newUnliftedMVar a = do + mv <- newEmptyUnliftedMVar + putUnliftedMVar mv a + pure mv + +newEmptyUnliftedMVar :: ST s (UnliftedMVar s a) +{-# INLINE newEmptyUnliftedMVar #-} +newEmptyUnliftedMVar = ST $ \s -> case newUnliftedMVar# s of + (# s', mv #) -> (# s', UnliftedMVar mv #) + +takeUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> ST s a +{-# INLINE takeUnliftedMVar #-} +takeUnliftedMVar = takeUnliftedMVar_ + +takeUnliftedMVarBox + :: UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a) +{-# INLINE takeUnliftedMVarBox #-} +takeUnliftedMVarBox = takeUnliftedMVar_ + +-- A version of takeUnliftedMVar that doesn't care about the +-- lifted type. We use this to specialize to Box so things can +-- get simplified more aggressively. This also avoids any +-- risk of exceptions happening in unexpected places in case +-- @toUnlifted#@ or @fromUnlifted#@ should fail. +takeUnliftedMVar_ + :: PrimUnlifted a + => UnliftedMVar_ s x (Unlifted a) -> ST s a +{-# INLINE takeUnliftedMVar_ #-} +takeUnliftedMVar_ (UnliftedMVar mv) = ST $ \s -> + case takeUnliftedMVar# mv s of + (# s', a #) -> (# s', fromUnlifted# a #) + +tryTakeUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> ST s (Maybe a) +{-# INLINE tryTakeUnliftedMVar #-} +tryTakeUnliftedMVar (UnliftedMVar mv) = ST $ \s -> + case tryTakeUnliftedMVar# mv s of + (# s', (# | a #) #) -> (# s', Just (fromUnlifted# a) #) + (# s', (# (##) | #) #) -> (# s', Nothing #) + +putUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> a -> ST s () +{-# INLINE putUnliftedMVar #-} +putUnliftedMVar = putUnliftedMVar_ + +putUnliftedMVarBox + :: UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s () +{-# INLINE putUnliftedMVarBox #-} +putUnliftedMVarBox = putUnliftedMVar_ + +-- A version of putUnliftedMVar that doesn't care about the +-- lifted type. We use this to specialize to Box so things can +-- get simplified more aggressively. This also avoids any +-- risk of exceptions happening in unexpected places in case +-- @toUnlifted#@ or @fromUnlifted#@ should fail. +putUnliftedMVar_ + :: PrimUnlifted a + => UnliftedMVar_ s x (Unlifted a) -> a -> ST s () +{-# INLINE putUnliftedMVar_ #-} +putUnliftedMVar_ (UnliftedMVar mv) a = primitive_ $ + putUnliftedMVar# mv (toUnlifted# a) + +tryPutUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> a -> ST s Bool +{-# INLINE tryPutUnliftedMVar #-} +tryPutUnliftedMVar (UnliftedMVar mv) a = ST $ \s -> + case tryPutUnliftedMVar# mv (toUnlifted# a) s of + (# s', 0# #) -> (# s', False #) + (# s', _ #) -> (# s', True #) + +readUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> ST s a +{-# INLINE readUnliftedMVar #-} +readUnliftedMVar (UnliftedMVar mv) = ST $ \s -> + case readUnliftedMVar# mv s of + (# s', a #) -> (# s', fromUnlifted# a #) + +tryReadUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar s a -> ST s (Maybe a) +{-# INLINE tryReadUnliftedMVar #-} +tryReadUnliftedMVar (UnliftedMVar mv) = ST $ \s -> + case tryReadUnliftedMVar# mv s of + (# s', (# (##) | #) #) -> (# s', Nothing #) + (# s', (# | a #) #) -> (# s', Just (fromUnlifted# a) #) + +isEmptyUnliftedMVar + :: UnliftedMVar s a -> ST s Bool +{-# INLINE isEmptyUnliftedMVar #-} +isEmptyUnliftedMVar (UnliftedMVar mv) = ST $ \s -> + case isEmptyUnliftedMVar# mv s of + (# s', 0# #) -> (# s', False #) + (# s', _ #) -> (# s', True #) + +swapUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar RealWorld a -> a -> ST RealWorld a +{-# INLINE swapUnliftedMVar #-} +swapUnliftedMVar mvar new = + fromBox <$> (mask_ $ do + old <- takeUnliftedMVarBox mvar + putUnliftedMVarBox mvar new_box + pure old) + where !new_box = toBox new + +withUnliftedMVar + :: PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b +{-# INLINE withUnliftedMVar #-} +withUnliftedMVar m f = + mask $ \restore -> do + a <- takeUnliftedMVarBox m + b <- restore (f (fromBox a)) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a + pure b + +withUnliftedMVarMasked + :: PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b +{-# INLINE withUnliftedMVarMasked #-} +withUnliftedMVarMasked m st = + mask_ $ do + a <- takeUnliftedMVarBox m + b <- st (fromBox a) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a + pure b + +data HalfUnlifted a b = HalfUnlifted !(Box (Unlifted a)) b + +-- Note: +-- Except in the "masked" functions, we are careful not to use +-- toUnlifted# or fromUnlifted# with exceptions masked. In theory, those +-- operations could be slow. +-- +-- mask, mask_, and onException deal in lifted values, which is a bit +-- annoying. The underlying primops do too. I wonder if that's essential. +-- Could we unsafeCoerce# our way to glory and let these functions return +-- unlifted pointers and even actions producing unboxed tuples? + +modifyUnliftedMVar + :: forall a b. PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld (a, b)) -> ST RealWorld b +{-# INLINE modifyUnliftedMVar #-} +modifyUnliftedMVar m st = + mask $ \restore -> do + a <- takeUnliftedMVarBox m + HalfUnlifted a' b :: HalfUnlifted a b <- restore + (do + (a', b) <- st (fromBox a) + pure $! HalfUnlifted (toBox a') b) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a' + pure b + +modifyUnliftedMVar_ + :: PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld a) -> ST RealWorld () +{-# INLINE modifyUnliftedMVar_ #-} +modifyUnliftedMVar_ m st = + mask $ \restore -> do + a <- takeUnliftedMVarBox m + a' <- restore (toBox <$> st (fromBox a)) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a' + +modifyUnliftedMVarMasked + :: forall a b. PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld (a, b)) -> ST RealWorld b +{-# INLINE modifyUnliftedMVarMasked #-} +modifyUnliftedMVarMasked m st = + mask_ $ do + a <- takeUnliftedMVarBox m + HalfUnlifted a' b :: HalfUnlifted a b <- + (do + (a', b) <- st (fromBox a) + pure $! HalfUnlifted (toBox a') b) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a' + pure b + +modifyUnliftedMVarMasked_ + :: PrimUnlifted a + => UnliftedMVar RealWorld a -> (a -> ST RealWorld a) -> ST RealWorld () +{-# INLINE modifyUnliftedMVarMasked_ #-} +modifyUnliftedMVarMasked_ m st = + mask_ $ do + a <- takeUnliftedMVarBox m + a' <- (toBox <$> st (fromBox a)) `onException` putUnliftedMVarBox m a + putUnliftedMVarBox m a' diff --git a/src/Data/Primitive/Unlifted/MutVar.hs b/src/Data/Primitive/Unlifted/MutVar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MutVar.hs @@ -0,0 +1,68 @@ +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language TypeFamilies #-} + +module Data.Primitive.Unlifted.MutVar + ( UnliftedMutVar_ (..) + , UnliftedMutVar + , newUnliftedMutVar + , readUnliftedMutVar + , writeUnliftedMutVar + , modifyUnliftedMutVar + , modifyUnliftedMutVar' + , casUnliftedMutVar + , atomicSwapUnliftedMutVar + ) where +import Data.Primitive.Unlifted.Class (PrimUnlifted) +import Control.Monad.Primitive (PrimMonad (PrimState), stToPrim) +import qualified Data.Primitive.Unlifted.MutVar.ST as M +import Data.Primitive.Unlifted.MutVar.ST (UnliftedMutVar_ (..), UnliftedMutVar) + +newUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => a -> m (UnliftedMutVar (PrimState m) a) +{-# INLINE newUnliftedMutVar #-} +newUnliftedMutVar a = stToPrim $ M.newUnliftedMutVar a + +readUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a -> m a +{-# INLINE readUnliftedMutVar #-} +readUnliftedMutVar mv = stToPrim $ M.readUnliftedMutVar mv + +writeUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a -> a -> m () +{-# INLINE writeUnliftedMutVar #-} +writeUnliftedMutVar mv a = stToPrim $ M.writeUnliftedMutVar mv a + +modifyUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a -> (a -> a) -> m () +{-# INLINE modifyUnliftedMutVar #-} +modifyUnliftedMutVar mv f = stToPrim $ M.modifyUnliftedMutVar mv f + +modifyUnliftedMutVar' + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a -> (a -> a) -> m () +{-# INLINE modifyUnliftedMutVar' #-} +modifyUnliftedMutVar' mv f = stToPrim $ M.modifyUnliftedMutVar' mv f + +casUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a -- ^ The 'UnliftedMutVar' on which to operate + -> a -- ^ The expected value + -> a -- ^ The new value to install if the 'UnliftedMutVar contains the expected value + -> m (Bool, a) +{-# INLINE casUnliftedMutVar #-} +casUnliftedMutVar mv old new = stToPrim $ M.casUnliftedMutVar mv old new + +atomicSwapUnliftedMutVar + :: (PrimMonad m, PrimUnlifted a) + => UnliftedMutVar (PrimState m) a + -> a + -> m a +{-# INLINE atomicSwapUnliftedMutVar #-} +atomicSwapUnliftedMutVar mv a = stToPrim $ M.atomicSwapUnliftedMutVar mv a diff --git a/src/Data/Primitive/Unlifted/MutVar/Primops.hs b/src/Data/Primitive/Unlifted/MutVar/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MutVar/Primops.hs @@ -0,0 +1,92 @@ +{-# language UnboxedTuples #-} +{-# language MagicHash #-} +{-# language UnliftedNewtypes #-} +{-# language ScopedTypeVariables #-} +{-# language RoleAnnotations #-} +{-# language KindSignatures #-} +{-# language DataKinds #-} + + +module Data.Primitive.Unlifted.MutVar.Primops + ( UnliftedMutVar# + , newUnliftedMutVar# + , readUnliftedMutVar# + , writeUnliftedMutVar# + , sameUnliftedMutVar# + , casUnliftedMutVar# + , atomicSwapUnliftedMutVar# + ) where + +import GHC.Exts (MutVar#, State#, Int#, newMutVar#, readMutVar#, writeMutVar#, reallyUnsafePtrEquality#, casMutVar#) + +import Data.Primitive.Unlifted.Type +import Data.Coerce + +-- | An @UnliftedMutVar#@ behaves like a single-element mutable array. +newtype UnliftedMutVar# s (a :: UnliftedType) = UnliftedMutVar# (MutVar# s a) +type role UnliftedMutVar# nominal representational + +newUnliftedMutVar# :: a -> State# s -> (# State# s, UnliftedMutVar# s a #) +{-# INLINE newUnliftedMutVar# #-} +newUnliftedMutVar# a s = coerce (newMutVar# a s) + +readUnliftedMutVar# :: UnliftedMutVar# s a -> State# s -> (# State# s, a #) +{-# INLINE readUnliftedMutVar# #-} +readUnliftedMutVar# (UnliftedMutVar# mv) s = readMutVar# mv s + +writeUnliftedMutVar# :: UnliftedMutVar# s a -> a -> State# s -> State# s +{-# INLINE writeUnliftedMutVar# #-} +writeUnliftedMutVar# (UnliftedMutVar# mv) a s + = writeMutVar# mv a s + +-- | Check whether two 'UnliftedMutVar#'es refer to the same mutable +-- variable. This is a check on object identity, and not on contents. +sameUnliftedMutVar# :: UnliftedMutVar# s a -> UnliftedMutVar# s a -> Int# +{-# INLINE sameUnliftedMutVar# #-} +sameUnliftedMutVar# (UnliftedMutVar# mv1) (UnliftedMutVar# mv2) + = reallyUnsafePtrEquality# mv1 mv2 + +-- Note: it's impossible to implement analogues of atomicModifyMutVar2# +-- or atomicModifyMutVar_# because those rely on being able to store +-- thunks in the variable. + +-- | Performs a machine-level compare and swap (CAS) operation on an +-- 'UnliftedMutVar#'. Returns a tuple containing an 'Int#' which is '1#' when a +-- swap is performed, along with the most "current" value from the +-- 'UnliftedMutVar#'. This return value can be used as the expected value if a +-- CAS loop is required, though it may be better to get a fresh read. Note +-- that this behavior differs from the more common CAS behavior, which is to +-- return the /old/ value before the CAS occured. +casUnliftedMutVar# + :: UnliftedMutVar# s a -- ^ The 'UnliftedMutVar#' on which to operate + -> a -- ^ The expected value + -> a -- ^ The new value to install if the 'UnliftedMutVar# contains the expected value + -> State# s -> (# State# s, Int#, a #) +{-# INLINE casUnliftedMutVar# #-} +casUnliftedMutVar# (UnliftedMutVar# mv) old new s + = coerce (casMutVar# mv old new s) + +-- | Atomically replace the value in an 'UnliftedMutVar#' with the given one, +-- returning the old value. +-- +-- Implementation note: this really should be a GHC primop, because it is +-- supported very efficiently in hardware, but unfortunately it's not (yet), so +-- we implement it as a CAS loop. +atomicSwapUnliftedMutVar# + :: UnliftedMutVar# s a -> a -> State# s -> (# State# s, a #) +{-# INLINE atomicSwapUnliftedMutVar# #-} +atomicSwapUnliftedMutVar# (UnliftedMutVar# mv) a s + = atomicSwapMutVar# mv a s + +atomicSwapMutVar# + :: forall s (a :: UnliftedType). MutVar# s a -> a -> State# s -> (# State# s, a #) +-- We don't bother inlining this because it's kind of slow regardless; +-- there doesn't seem to be much point. We don't use the "latest" +-- value reported by casUnliftedMutVar# because I'm told chances of +-- CAS success are better if we use a perfectly fresh value than if +-- we take the time to check for CAS success in between. +atomicSwapMutVar# mv a s + = case readMutVar# mv s of { (# s', old #) -> + case casMutVar# mv old a s' of + (# s'', 0#, _ #) -> atomicSwapMutVar# mv a s'' + (# s'', _, _ #) -> (# s'', old #) } diff --git a/src/Data/Primitive/Unlifted/MutVar/ST.hs b/src/Data/Primitive/Unlifted/MutVar/ST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/MutVar/ST.hs @@ -0,0 +1,104 @@ +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} + +module Data.Primitive.Unlifted.MutVar.ST + ( UnliftedMutVar_ (..) + , UnliftedMutVar + , newUnliftedMutVar + , readUnliftedMutVar + , writeUnliftedMutVar + , modifyUnliftedMutVar + , modifyUnliftedMutVar' + , casUnliftedMutVar + , atomicSwapUnliftedMutVar + ) where +import Data.Primitive.Unlifted.MutVar.Primops +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import GHC.ST (ST (..)) +import GHC.Exts (isTrue#, State#) + +data UnliftedMutVar_ s a unlifted_a = UnliftedMutVar (UnliftedMutVar# s unlifted_a) +type role UnliftedMutVar_ nominal phantom representational + +type UnliftedMutVar s a = UnliftedMutVar_ s a (Unlifted a) + +instance (unlifted_a ~ Unlifted a) => PrimUnlifted (UnliftedMutVar_ s a unlifted_a) where + {-# INLINE toUnlifted# #-} + {-# INLINE fromUnlifted# #-} + type Unlifted (UnliftedMutVar_ s a unlifted_a) = UnliftedMutVar# s unlifted_a + toUnlifted# (UnliftedMutVar m) = m + fromUnlifted# m = UnliftedMutVar m + +instance (unlifted_a ~ Unlifted a) => Eq (UnliftedMutVar_ s a unlifted_a) where + {-# INLINE (==) #-} + UnliftedMutVar m1 == UnliftedMutVar m2 + = isTrue# (sameUnliftedMutVar# m1 m2) + +primitive_ :: (State# s -> State# s) -> ST s () +{-# INLINE primitive_ #-} +primitive_ f = ST $ \s -> (# f s, () #) + +newUnliftedMutVar + :: PrimUnlifted a + => a -> ST s (UnliftedMutVar s a) +{-# INLINE newUnliftedMutVar #-} +newUnliftedMutVar a + = ST $ \s -> case newUnliftedMutVar# (toUnlifted# a) s of + (# s', mv #) -> (# s', UnliftedMutVar mv #) + +readUnliftedMutVar + :: PrimUnlifted a + => UnliftedMutVar s a -> ST s a +{-# INLINE readUnliftedMutVar #-} +readUnliftedMutVar (UnliftedMutVar mv) + = ST $ \s -> case readUnliftedMutVar# mv s of + (# s', a #) -> (# s', fromUnlifted# a #) + +writeUnliftedMutVar + :: PrimUnlifted a + => UnliftedMutVar s a -> a -> ST s () +{-# INLINE writeUnliftedMutVar #-} +writeUnliftedMutVar (UnliftedMutVar mv) a + = primitive_ $ writeUnliftedMutVar# mv (toUnlifted# a) + +modifyUnliftedMutVar + :: PrimUnlifted a + => UnliftedMutVar s a -> (a -> a) -> ST s () +{-# INLINE modifyUnliftedMutVar #-} +modifyUnliftedMutVar mv f = do + a <- readUnliftedMutVar mv + writeUnliftedMutVar mv (f a) + +modifyUnliftedMutVar' + :: PrimUnlifted a + => UnliftedMutVar s a -> (a -> a) -> ST s () +{-# INLINE modifyUnliftedMutVar' #-} +modifyUnliftedMutVar' mv f = do + a <- readUnliftedMutVar mv + writeUnliftedMutVar mv $! f a + +casUnliftedMutVar + :: PrimUnlifted a + => UnliftedMutVar s a -- ^ The 'UnliftedMutVar' on which to operate + -> a -- ^ The expected value + -> a -- ^ The new value to install if the 'UnliftedMutVar contains the expected value + -> ST s (Bool, a) +{-# INLINE casUnliftedMutVar #-} +casUnliftedMutVar (UnliftedMutVar mv) old new = ST $ \s -> + case casUnliftedMutVar# mv (toUnlifted# old) (toUnlifted# new) s of + (# s', 0#, latest #) -> (# s', (False, fromUnlifted# latest) #) + (# s', _, latest #) -> (# s', (True, fromUnlifted# latest) #) + +atomicSwapUnliftedMutVar + :: PrimUnlifted a + => UnliftedMutVar s a + -> a + -> ST s a +{-# INLINE atomicSwapUnliftedMutVar #-} +atomicSwapUnliftedMutVar (UnliftedMutVar mv) a + = ST $ \s -> case atomicSwapUnliftedMutVar# mv (toUnlifted# a) s of + (# s', old #) -> (# s', fromUnlifted# old #) diff --git a/src/Data/Primitive/Unlifted/SmallArray.hs b/src/Data/Primitive/Unlifted/SmallArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/SmallArray.hs @@ -0,0 +1,214 @@ +{-# language BangPatterns #-} +{-# language MagicHash #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} + +-- | +-- GHC contains three general classes of value types: +-- +-- 1. Unboxed types: values are machine values made up of fixed numbers of bytes. +-- These include types like @Int#@, @Char#@ and @Addr#@. +-- 2. Unlifted types: values are pointers, but strictly evaluated. These include +-- types like @MutVar# s a@, @Array# a@, and @MVar# s a@. +-- 3. Lifted types: values are pointers, lazily evaluated. +-- +-- Certain lifted types are really just thin wrappers around unboxed types (we can call +-- these category 3a) or unlifted pointer types (we can call these category 3b) +-- Category 3a includes `Int`, `Char`, and `Ptr a`, while category 3b includes +-- @IORef a@, @Data.Primitive.Array.Array a@, and @MVar a@. +-- +-- Types in category 3a can be stored efficiently in a @Data.Primitive.PrimArray.PrimArray@, +-- removing and applying wrappers as required. This module provides the same facility for +-- types in category 3b. +module Data.Primitive.Unlifted.SmallArray + ( -- * Types + A.SmallUnliftedArray_(..) + , A.SmallUnliftedArray + , A.SmallMutableUnliftedArray_(..) + , A.SmallMutableUnliftedArray + -- * Operations + , newSmallUnliftedArray + , unsafeNewSmallUnliftedArray + , A.sizeofSmallUnliftedArray + , getSizeofSmallMutableUnliftedArray + , A.sameSmallMutableUnliftedArray + , shrinkSmallMutableUnliftedArray + , writeSmallUnliftedArray + , readSmallUnliftedArray + , A.indexSmallUnliftedArray + , unsafeFreezeSmallUnliftedArray + , freezeSmallUnliftedArray + , thawSmallUnliftedArray + , unsafeThawSmallUnliftedArray + , setSmallUnliftedArray + , copySmallUnliftedArray + , copySmallMutableUnliftedArray + , A.cloneSmallUnliftedArray + , cloneSmallMutableUnliftedArray + , A.emptySmallUnliftedArray + , A.singletonSmallUnliftedArray + , A.runSmallUnliftedArray + , A.dupableRunSmallUnliftedArray + -- * List Conversion + , A.smallUnliftedArrayToList + , A.smallUnliftedArrayFromList + , A.smallUnliftedArrayFromListN + -- * Folding + , A.foldrSmallUnliftedArray + , A.foldrSmallUnliftedArray' + , A.foldlSmallUnliftedArray + , A.foldlSmallUnliftedArray' + , A.foldlSmallUnliftedArrayM' + -- * Traversals + , A.traverseSmallUnliftedArray_ + , A.itraverseSmallUnliftedArray_ + -- * Mapping + , A.mapSmallUnliftedArray + ) where + +import Control.Monad.Primitive (PrimMonad,PrimState,stToPrim) +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import qualified Data.Primitive.Unlifted.SmallArray.ST as A +import Data.Primitive.Unlifted.SmallArray.ST (SmallUnliftedArray, SmallMutableUnliftedArray) + +-- | Creates a new 'MutableUnliftedArray' with the specified value as initial +-- contents. +newSmallUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => Int -- ^ size + -> a -- ^ initial value + -> m (SmallMutableUnliftedArray (PrimState m) a) +newSmallUnliftedArray len v = stToPrim $ A.newSmallUnliftedArray len v +{-# inline newSmallUnliftedArray #-} + +setSmallUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => SmallMutableUnliftedArray (PrimState m) a -- ^ destination + -> a -- ^ value to fill with + -> Int -- ^ offset + -> Int -- ^ length + -> m () +{-# inline setSmallUnliftedArray #-} +setSmallUnliftedArray mua v off len = stToPrim $ A.setSmallUnliftedArray mua v off len + +shrinkSmallMutableUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a + -> Int + -> m () +shrinkSmallMutableUnliftedArray mary sz = stToPrim $ A.shrinkSmallMutableUnliftedArray mary sz +{-# inline shrinkSmallMutableUnliftedArray #-} + +writeSmallUnliftedArray :: (PrimMonad m, PrimUnlifted a) + => SmallMutableUnliftedArray (PrimState m) a + -> Int + -> a + -> m () +{-# inline writeSmallUnliftedArray #-} +writeSmallUnliftedArray mary ix a = stToPrim $ A.writeSmallUnliftedArray mary ix a + +readSmallUnliftedArray :: (PrimMonad m, PrimUnlifted a) + => SmallMutableUnliftedArray (PrimState m) a + -> Int + -> m a +{-# inline readSmallUnliftedArray #-} +readSmallUnliftedArray mary ix = stToPrim $ A.readSmallUnliftedArray mary ix + +-- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply +-- marks the array as frozen in place, so it should only be used when no further +-- modifications to the mutable array will be performed. +unsafeFreezeSmallUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a + -> m (SmallUnliftedArray a) +unsafeFreezeSmallUnliftedArray mary = stToPrim $ A.unsafeFreezeSmallUnliftedArray mary +{-# inline unsafeFreezeSmallUnliftedArray #-} + +-- | Copies the contents of an immutable array into a mutable array. +copySmallUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a -- ^ destination + -> Int -- ^ offset into destination + -> SmallUnliftedArray a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> m () +{-# inline copySmallUnliftedArray #-} +copySmallUnliftedArray dst doff src soff ln = stToPrim $ A.copySmallUnliftedArray dst doff src soff ln + +-- | Copies the contents of one mutable array into another. +copySmallMutableUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a -- ^ destination + -> Int -- ^ offset into destination + -> SmallMutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> m () +{-# inline copySmallMutableUnliftedArray #-} +copySmallMutableUnliftedArray dst doff src soff ln = stToPrim $ A.copySmallMutableUnliftedArray dst doff src soff ln + +-- | Freezes a portion of a 'SmallMutableUnliftedArray', yielding a 'SmallUnliftedArray'. +-- This operation is safe, in that it copies the frozen portion, and the +-- existing mutable array may still be used afterward. +freezeSmallUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallUnliftedArray a) +freezeSmallUnliftedArray mary off len = stToPrim $ A.freezeSmallUnliftedArray mary off len +{-# inline freezeSmallUnliftedArray #-} + +-- | Thaws a portion of a 'SmallUnliftedArray', yielding a 'SmallMutableUnliftedArray'. +-- This copies the thawed portion, so mutations will not affect the original +-- array. +thawSmallUnliftedArray + :: PrimMonad m + => SmallUnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableUnliftedArray (PrimState m) a) +{-# inline thawSmallUnliftedArray #-} +thawSmallUnliftedArray ary off len = stToPrim $ A.thawSmallUnliftedArray ary off len + +-- | Thaw a 'SmallUnliftedArray', yielding a 'SmallMutableUnliftedArray'. +-- This does not make a copy. +unsafeThawSmallUnliftedArray + :: PrimMonad m + => SmallUnliftedArray a -- ^ source + -> m (SmallMutableUnliftedArray (PrimState m) a) +{-# inline unsafeThawSmallUnliftedArray #-} +unsafeThawSmallUnliftedArray ary = stToPrim $ A.unsafeThawSmallUnliftedArray ary + +-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it +-- initializes all elements of the array as pointers to the empty array. Attempting +-- to read one of these elements before writing to it is in effect an unsafe +-- coercion from @'UnliftedArray' a@ to the element type. +unsafeNewSmallUnliftedArray + :: PrimMonad m + => Int -- ^ size + -> m (SmallMutableUnliftedArray (PrimState m) a) +{-# inline unsafeNewSmallUnliftedArray #-} +unsafeNewSmallUnliftedArray len = stToPrim $ A.unsafeNewSmallUnliftedArray len + +-- | Yields the length of a 'MutableUnliftedArray'. +getSizeofSmallMutableUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a + -> m Int +getSizeofSmallMutableUnliftedArray a = stToPrim $ A.getSizeofSmallMutableUnliftedArray a + +-- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of +-- another mutable array. +cloneSmallMutableUnliftedArray + :: PrimMonad m + => SmallMutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableUnliftedArray (PrimState m) a) +{-# inline cloneSmallMutableUnliftedArray #-} +cloneSmallMutableUnliftedArray mary off len = stToPrim $ A.cloneSmallMutableUnliftedArray mary off len diff --git a/src/Data/Primitive/Unlifted/SmallArray/Primops.hs b/src/Data/Primitive/Unlifted/SmallArray/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/SmallArray/Primops.hs @@ -0,0 +1,201 @@ +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} +{-# language UnliftedNewtypes #-} +{-# language KindSignatures #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language DataKinds #-} +{-# language UnliftedDatatypes #-} + +-- | +-- Primitive types representing unlifted arrays and the +-- primops for manipulating them. +module Data.Primitive.Unlifted.SmallArray.Primops + ( -- * Types + SmallUnliftedArray#(..) + , SmallMutableUnliftedArray#(..) + -- We don't export the newtype constructors because they're bogus and + -- because there's basically no reason they'd ever be used. This module + -- contains a wrapped version of every Array# primop. Eventually, all this + -- stuff will be in GHC.Prim, possibly with other names. + + -- * Operations + , newSmallUnliftedArray# + , unsafeNewSmallUnliftedArray# + , emptySmallUnliftedArray# + , sameSmallMutableUnliftedArray# + , shrinkSmallMutableUnliftedArray# + , readSmallUnliftedArray# + , writeSmallUnliftedArray# + , sizeofSmallUnliftedArray# + , getSizeofSmallMutableUnliftedArray# + , indexSmallUnliftedArray# + , unsafeFreezeSmallUnliftedArray# + , unsafeThawSmallUnliftedArray# + , copySmallUnliftedArray# + , copySmallMutableUnliftedArray# + , cloneSmallUnliftedArray# + , cloneSmallMutableUnliftedArray# + , freezeSmallUnliftedArray# + , thawSmallUnliftedArray# + , casSmallUnliftedArray# + ) where + +import Data.Coerce (coerce) +import GHC.Exts (Int#,State#,SmallArray#,SmallMutableArray#) +import qualified GHC.Exts as Exts + +import Data.Primitive.Unlifted.Type +import Unsafe.Coerce (unsafeCoerceUnlifted) + +newtype SmallUnliftedArray# (a :: UnliftedType) = SmallUnliftedArray# (SmallArray# a) +type role SmallUnliftedArray# representational + +newtype SmallMutableUnliftedArray# s (a :: UnliftedType) = SmallMutableUnliftedArray# (SmallMutableArray# s a) +type role SmallMutableUnliftedArray# nominal representational + +newSmallUnliftedArray# :: forall a s. Int# -> a -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) +newSmallUnliftedArray# sz a s = coerce (Exts.newSmallArray# sz a s) +{-# INLINE newSmallUnliftedArray# #-} + +-- | Create a 'SmallMutableUnliftedArray#' whose entries contain some unspecified +-- static value. This may be more convenient than 'newUnliftedArray#' if there +-- is no value on hand with which to initialize the array. Each entry must be +-- initialized before being read and used. This condition is not checked. +unsafeNewSmallUnliftedArray# :: Int# -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) +-- We fill the array with the Nonsense data constructor. It doesn't much matter +-- *what* we stick in there, as long as it's a pointer the garbage collector +-- can understand and isn't something that might otherwise be released as garbage. +-- There's no point trying to stick an `error` in there, because there's no +-- code anywhere to force the error thunk. +unsafeNewSmallUnliftedArray# sz s = case Exts.newSmallArray# sz (unsafeCoerceUnlifted Nonsense) s of + (# s', mary #) -> (# s', SmallMutableUnliftedArray# mary #) +{-# INLINE unsafeNewSmallUnliftedArray# #-} + +type Nonsense :: UnliftedType +data Nonsense = Nonsense + + +-- This represents a *statically allocated* value, preferably in a *read-only* +-- segment of memory. +-- +-- Why do we bother to noDuplicate#? It generally doesn't much *matter* if +-- different threads have different global empty arrays. However, for +-- performance testing purposes, a user may well want to check whether the +-- empty arrays they expect to be the global ones really are. Such a test +-- is only possible if there's just *one* array to test against. The overhead +-- of the once-ever noDuplicate# call is sure to be trivial anyway. +empty_small_unlifted_array :: SULA a +empty_small_unlifted_array = SULA + (Exts.runRW# $ \s -> + case Exts.noDuplicate# s of { s' -> + case Exts.newSmallArray# 0# (unsafeCoerceUnlifted Nonsense) s' of { (# s'', mary #) -> + case Exts.unsafeFreezeSmallArray# mary s'' of { (# _, ary #) -> + SmallUnliftedArray# ary }}}) +{-# NOINLINE empty_small_unlifted_array #-} + +data SULA a = SULA (SmallUnliftedArray# a) + +-- | Warning: Applying 'unsafeThawUnliftedArray#' to the array produced by +-- this function will make demons come out of your nose. +emptySmallUnliftedArray# :: (##) -> SmallUnliftedArray# a +-- We make this primitive because it's the easiest way to get a +-- *shared* primitive unlifted array. +-- +-- Why the stern warning above? GHC does not currently support resizing 'Array#', +-- and does not really meaningfully support *growing* arrays of any type. If, +-- however, that ever changes, growing the globally shared empty array would be +-- pretty disastrous. +emptySmallUnliftedArray# (##) = case empty_small_unlifted_array of + SULA ary -> ary +{-# INLINE emptySmallUnliftedArray# #-} + +sameSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> SmallMutableUnliftedArray# s a -> Int# +sameSmallMutableUnliftedArray# (SmallMutableUnliftedArray# ar1) (SmallMutableUnliftedArray# ar2) + = Exts.reallyUnsafePtrEquality# ar1 ar2 +{-# INLINE sameSmallMutableUnliftedArray# #-} + +shrinkSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> State# s -> State# s +shrinkSmallMutableUnliftedArray# (SmallMutableUnliftedArray# ar) sz s + = Exts.shrinkSmallMutableArray# ar sz s +{-# INLINE shrinkSmallMutableUnliftedArray# #-} + +readSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> State# s -> (# State# s, a #) +readSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i s + = Exts.readSmallArray# mary i s +{-# INLINE readSmallUnliftedArray# #-} + +writeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> a -> State# s -> State# s +writeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i a s + = Exts.writeSmallArray# mary i a s +{-# INLINE writeSmallUnliftedArray# #-} + +sizeofSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# +sizeofSmallUnliftedArray# (SmallUnliftedArray# ary) = Exts.sizeofSmallArray# ary +{-# INLINE sizeofSmallUnliftedArray# #-} + +getSizeofSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> State# s -> (# State# s, Int# #) +getSizeofSmallMutableUnliftedArray# (SmallMutableUnliftedArray# mary) s + = Exts.getSizeofSmallMutableArray# mary s +{-# INLINE getSizeofSmallMutableUnliftedArray# #-} + +{- +--The underlying primop is deprecated in GHC.Prim, so let's not do this. +sizeofSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# +sizeofSmallMutableUnliftedArray# (SmallMutableUnliftedArray# mary) + = Exts.sizeofSmallMutableArray# mary +{-# INLINE sizeofSmallMutableUnliftedArray# #-} +-} + +indexSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> a +indexSmallUnliftedArray# (SmallUnliftedArray# ary) i + | (# a #) <- Exts.indexSmallArray# ary i + = a +{-# INLINE indexSmallUnliftedArray# #-} + +unsafeFreezeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> State# s -> (# State# s, SmallUnliftedArray# a #) +unsafeFreezeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) s + = coerce (Exts.unsafeFreezeSmallArray# mary s) +{-# INLINE unsafeFreezeSmallUnliftedArray# #-} + +unsafeThawSmallUnliftedArray# :: SmallUnliftedArray# a -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) +unsafeThawSmallUnliftedArray# (SmallUnliftedArray# ary) s + = coerce (Exts.unsafeThawSmallArray# ary s) +{-# INLINE unsafeThawSmallUnliftedArray# #-} + +copySmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s +copySmallUnliftedArray# (SmallUnliftedArray# ary) i1 (SmallMutableUnliftedArray# mary) i2 n s + = Exts.copySmallArray# ary i1 mary i2 n s +{-# INLINE copySmallUnliftedArray# #-} + +copySmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s -> State# s +copySmallMutableUnliftedArray# (SmallMutableUnliftedArray# mary1) i1 (SmallMutableUnliftedArray# mary2) i2 n s + = Exts.copySmallMutableArray# mary1 i1 mary2 i2 n s +{-# INLINE copySmallMutableUnliftedArray# #-} + +cloneSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> Int# -> SmallUnliftedArray# a +cloneSmallUnliftedArray# (SmallUnliftedArray# ary) i n + = SmallUnliftedArray# (Exts.cloneSmallArray# ary i n) +{-# INLINE cloneSmallUnliftedArray# #-} + +cloneSmallMutableUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s + -> (# State# s, SmallMutableUnliftedArray# s a #) +cloneSmallMutableUnliftedArray# (SmallMutableUnliftedArray# mary) i n s + = coerce (Exts.cloneSmallMutableArray# mary i n s) +{-# INLINE cloneSmallMutableUnliftedArray# #-} + +freezeSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallUnliftedArray# a #) +freezeSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i n s + = coerce (Exts.freezeSmallArray# mary i n s) +{-# INLINE freezeSmallUnliftedArray# #-} + +thawSmallUnliftedArray# :: SmallUnliftedArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableUnliftedArray# s a #) +thawSmallUnliftedArray# (SmallUnliftedArray# ary) i n s + = coerce (Exts.thawSmallArray# ary i n s) +{-# INLINE thawSmallUnliftedArray# #-} + +casSmallUnliftedArray# :: SmallMutableUnliftedArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) +casSmallUnliftedArray# (SmallMutableUnliftedArray# mary) i x y s + = Exts.casSmallArray# mary i x y s +{-# INLINE casSmallUnliftedArray# #-} diff --git a/src/Data/Primitive/Unlifted/SmallArray/ST.hs b/src/Data/Primitive/Unlifted/SmallArray/ST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/SmallArray/ST.hs @@ -0,0 +1,544 @@ +{-# language BangPatterns #-} +{-# language MagicHash #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UnboxedTuples #-} +{-# language RoleAnnotations #-} + +-- | +-- A version of the 'Data.Primitive.Unlifted.SmallArray' interface +-- specialized to 'ST'. This is intended primarily so library +-- developers can easily check whether the basic operations are +-- unboxed properly, but its more constrained type signatures +-- also offer somewhat better type inference where applicable. +module Data.Primitive.Unlifted.SmallArray.ST + ( -- * Types + SmallUnliftedArray_(..) + , SmallUnliftedArray + , SmallMutableUnliftedArray_(..) + , SmallMutableUnliftedArray + -- * Operations + , newSmallUnliftedArray + , unsafeNewSmallUnliftedArray + , sizeofSmallUnliftedArray + , getSizeofSmallMutableUnliftedArray + , sameSmallMutableUnliftedArray + , shrinkSmallMutableUnliftedArray + , writeSmallUnliftedArray + , readSmallUnliftedArray + , indexSmallUnliftedArray + , unsafeFreezeSmallUnliftedArray + , freezeSmallUnliftedArray + , thawSmallUnliftedArray + , unsafeThawSmallUnliftedArray + , setSmallUnliftedArray + , copySmallUnliftedArray + , copySmallMutableUnliftedArray + , cloneSmallUnliftedArray + , cloneSmallMutableUnliftedArray + , emptySmallUnliftedArray + , singletonSmallUnliftedArray + , runSmallUnliftedArray + , dupableRunSmallUnliftedArray + -- * List Conversion + , smallUnliftedArrayToList + , smallUnliftedArrayFromList + , smallUnliftedArrayFromListN + -- * Folding + , foldrSmallUnliftedArray + , foldrSmallUnliftedArray' + , foldlSmallUnliftedArray + , foldlSmallUnliftedArray' + , foldlSmallUnliftedArrayM' + -- * Traversals + , traverseSmallUnliftedArray_ + , itraverseSmallUnliftedArray_ + -- * Mapping + , mapSmallUnliftedArray + ) where + +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import Data.Primitive.Unlifted.SmallArray.Primops +import GHC.Exts (Int(I#),State#) +import GHC.ST (ST (..)) + +import qualified Data.List as L +import qualified GHC.Exts as Exts + +-- | Using a specialized copy of primitive_ here makes the Core a little +-- easier to read by eliminating unnecessary PrimState coercions. +primitive_ :: (State# s -> State# s) -> ST s () +{-# INLINE primitive_ #-} +primitive_ m = ST (\s -> (# m s, () #)) + +-- | A @SmallUnliftedArray_ a unlifted_a@ represents an array of values of a +-- lifted type @a@ that wrap values of an unlifted type @unlifted_a@. +-- It is expected that @unlifted_a ~ Unlifted a@, but imposing that constraint +-- here would force the type roles to @nominal@, which is often undesirable +-- when arrays are used as components of larger datatypes. +data SmallUnliftedArray_ unlifted_a a + = SmallUnliftedArray (SmallUnliftedArray# unlifted_a) +type role SmallUnliftedArray_ representational phantom + +-- | A type synonym for a 'SmallUnliftedArray_' containing lifted values of +-- a particular type. As a general rule, this type synonym should not be used in +-- class instances—use 'SmallUnliftedArray_' with an equality constraint instead. +-- It also should not be used when defining newtypes or datatypes, unless those +-- will have restrictive type roles regardless—use 'SmallUnliftedArray_' instead. +type SmallUnliftedArray a = SmallUnliftedArray_ (Unlifted a) a + +data SmallMutableUnliftedArray_ unlifted_a s a + = SmallMutableUnliftedArray (SmallMutableUnliftedArray# s unlifted_a) +type role SmallMutableUnliftedArray_ representational nominal phantom + +type SmallMutableUnliftedArray s a = SmallMutableUnliftedArray_ (Unlifted a) s a + +instance unlifted_a ~ Unlifted a => PrimUnlifted (SmallUnliftedArray_ unlifted_a a) where + type Unlifted (SmallUnliftedArray_ unlifted_a _) = SmallUnliftedArray# unlifted_a + toUnlifted# (SmallUnliftedArray a) = a + fromUnlifted# x = SmallUnliftedArray x + +instance unlifted_a ~ Unlifted a => PrimUnlifted (SmallMutableUnliftedArray_ unlifted_a s a) where + type Unlifted (SmallMutableUnliftedArray_ unlifted_a s _) = SmallMutableUnliftedArray# s unlifted_a + toUnlifted# (SmallMutableUnliftedArray a) = a + fromUnlifted# x = SmallMutableUnliftedArray x + +-- | Creates a new 'MutableUnliftedArray' with the specified value as initial +-- contents. +newSmallUnliftedArray + :: PrimUnlifted a + => Int -- ^ size + -> a -- ^ initial value + -> ST s (SmallMutableUnliftedArray s a) +newSmallUnliftedArray (I# len) v = ST $ \s -> case newSmallUnliftedArray# len (toUnlifted# v) s of + (# s', ma #) -> (# s', SmallMutableUnliftedArray ma #) +{-# inline newSmallUnliftedArray #-} + +setSmallUnliftedArray + :: PrimUnlifted a + => SmallMutableUnliftedArray s a -- ^ destination + -> a -- ^ value to fill with + -> Int -- ^ offset + -> Int -- ^ length + -> ST s () +{-# inline setSmallUnliftedArray #-} +setSmallUnliftedArray mua v off len = loop (len + off - 1) + where + loop i + | i < off = pure () + | otherwise = writeSmallUnliftedArray mua i v *> loop (i-1) + +-- | Yields the length of an 'UnliftedArray'. +sizeofSmallUnliftedArray :: SmallUnliftedArray_ unlifted_e e -> Int +{-# inline sizeofSmallUnliftedArray #-} +sizeofSmallUnliftedArray (SmallUnliftedArray ar) = I# (sizeofSmallUnliftedArray# ar) + +-- | Yields the length of a 'MutableUnliftedArray'. +getSizeofSmallMutableUnliftedArray :: SmallMutableUnliftedArray s e -> ST s Int +{-# inline getSizeofSmallMutableUnliftedArray #-} +getSizeofSmallMutableUnliftedArray (SmallMutableUnliftedArray maa#) + = ST (\s -> case getSizeofSmallMutableUnliftedArray# maa# s of + (# s', sz #) -> (# s', I# sz #)) + +writeSmallUnliftedArray :: PrimUnlifted a + => SmallMutableUnliftedArray s a + -> Int + -> a + -> ST s () +{-# inline writeSmallUnliftedArray #-} +writeSmallUnliftedArray (SmallMutableUnliftedArray arr) (I# ix) a = + primitive_ (writeSmallUnliftedArray# arr ix (toUnlifted# a)) + +readSmallUnliftedArray :: PrimUnlifted a + => SmallMutableUnliftedArray s a + -> Int + -> ST s a +{-# inline readSmallUnliftedArray #-} +readSmallUnliftedArray (SmallMutableUnliftedArray arr) (I# ix) = + ST $ \s -> case readSmallUnliftedArray# arr ix s of + (# s', a #) -> (# s', fromUnlifted# a #) + +indexSmallUnliftedArray :: PrimUnlifted a + => SmallUnliftedArray a + -> Int + -> a +{-# inline indexSmallUnliftedArray #-} +indexSmallUnliftedArray (SmallUnliftedArray arr) (I# ix) = + fromUnlifted# (indexSmallUnliftedArray# arr ix) + +-- | Freezes a 'SmallMutableUnliftedArray', yielding a 'SmallUnliftedArray'. +-- This simply marks the array as frozen in place, so it should only be used +-- when no further modifications to the mutable array will be performed. +unsafeFreezeSmallUnliftedArray + :: SmallMutableUnliftedArray s a + -> ST s (SmallUnliftedArray a) +unsafeFreezeSmallUnliftedArray (SmallMutableUnliftedArray maa#) + = ST $ \s -> case unsafeFreezeSmallUnliftedArray# maa# s of + (# s', aa# #) -> (# s', SmallUnliftedArray aa# #) +{-# inline unsafeFreezeSmallUnliftedArray #-} + +-- | Determines whether two 'MutableUnliftedArray' values are the same. This is +-- object/pointer identity, not based on the contents. +sameSmallMutableUnliftedArray + :: SmallMutableUnliftedArray_ unlifted_a s a + -> SmallMutableUnliftedArray_ unlifted_a s a + -> Bool +sameSmallMutableUnliftedArray (SmallMutableUnliftedArray maa1#) (SmallMutableUnliftedArray maa2#) + = Exts.isTrue# (sameSmallMutableUnliftedArray# maa1# maa2#) +{-# inline sameSmallMutableUnliftedArray #-} + +-- | Shrink a mutable array to the specified size. The new size argument must be less than or +-- equal to the current size. +shrinkSmallMutableUnliftedArray :: SmallMutableUnliftedArray s a -> Int -> ST s () +shrinkSmallMutableUnliftedArray (SmallMutableUnliftedArray mary) (I# sz) + = primitive_ $ shrinkSmallMutableUnliftedArray# mary sz +{-# inline shrinkSmallMutableUnliftedArray #-} + +-- | Copies the contents of an immutable array into a mutable array. +copySmallUnliftedArray + :: SmallMutableUnliftedArray s a -- ^ destination + -> Int -- ^ offset into destination + -> SmallUnliftedArray a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> ST s () +{-# inline copySmallUnliftedArray #-} +copySmallUnliftedArray + (SmallMutableUnliftedArray dst) (I# doff) + (SmallUnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copySmallUnliftedArray# src soff dst doff ln + +-- | Copies the contents of one mutable array into another. +copySmallMutableUnliftedArray + :: SmallMutableUnliftedArray s a -- ^ destination + -> Int -- ^ offset into destination + -> SmallMutableUnliftedArray s a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> ST s () +{-# inline copySmallMutableUnliftedArray #-} +copySmallMutableUnliftedArray + (SmallMutableUnliftedArray dst) (I# doff) + (SmallMutableUnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copySmallMutableUnliftedArray# src soff dst doff ln + +-- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. +-- This operation is safe, in that it copies the frozen portion, and the +-- existing mutable array may still be used afterward. +freezeSmallUnliftedArray + :: SmallMutableUnliftedArray s a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (SmallUnliftedArray a) +freezeSmallUnliftedArray (SmallMutableUnliftedArray mary) (I# off) (I# len) = + ST $ \s -> case freezeSmallUnliftedArray# mary off len s of + (# s', ary #) -> (# s', SmallUnliftedArray ary #) +{-# inline freezeSmallUnliftedArray #-} + +-- | Thaws a portion of a 'SmallUnliftedArray', yielding a 'SmallMutableUnliftedArray'. +-- This copies the thawed portion, so mutations will not affect the original +-- array. +thawSmallUnliftedArray + :: SmallUnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (SmallMutableUnliftedArray s a) +{-# inline thawSmallUnliftedArray #-} +thawSmallUnliftedArray (SmallUnliftedArray ary) (I# off) (I# len) = + ST $ \s -> case thawSmallUnliftedArray# ary off len s of + (# s', mary #) -> (# s', SmallMutableUnliftedArray mary #) + +-- | Thaws a 'SmallUnliftedArray', yielding a 'SmallMutableUnliftedArray'. +-- This does not make a copy. +unsafeThawSmallUnliftedArray + :: SmallUnliftedArray a -- ^ source + -> ST s (SmallMutableUnliftedArray s a) +{-# inline unsafeThawSmallUnliftedArray #-} +unsafeThawSmallUnliftedArray (SmallUnliftedArray ary) = + ST $ \s -> case unsafeThawSmallUnliftedArray# ary s of + (# s', mary #) -> (# s', SmallMutableUnliftedArray mary #) + +-- | Execute a stateful computation and freeze the resulting array. +runSmallUnliftedArray + :: (forall s. ST s (SmallMutableUnliftedArray s a)) + -> SmallUnliftedArray a +{-# INLINE runSmallUnliftedArray #-} +-- This is what we'd like to write, but GHC does not yet +-- produce properly unboxed code when we do +-- runUnliftedArray m = runST $ noDuplicate >> m >>= unsafeFreezeUnliftedArray +runSmallUnliftedArray m = SmallUnliftedArray (runSmallUnliftedArray# m) + +runSmallUnliftedArray# + :: (forall s. ST s (SmallMutableUnliftedArray s a)) + -> SmallUnliftedArray# (Unlifted a) +runSmallUnliftedArray# m = case Exts.runRW# $ \s0 -> + case Exts.noDuplicate# s0 of { s -> + case unST m s of { (# s', SmallMutableUnliftedArray mary# #) -> + unsafeFreezeSmallUnliftedArray# mary# s'}} of (# _, ary# #) -> ary# +{-# INLINE runSmallUnliftedArray# #-} + +-- | Execute a stateful computation and freeze the resulting array. +-- It is possible, but unlikely, that the computation will be run +-- multiple times in multiple threads. +dupableRunSmallUnliftedArray + :: (forall s. ST s (SmallMutableUnliftedArray s a)) + -> SmallUnliftedArray a +{-# INLINE dupableRunSmallUnliftedArray #-} +-- This is what we'd like to write, but GHC does not yet +-- produce properly unboxed code when we do +-- dupableRunUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray +dupableRunSmallUnliftedArray m = SmallUnliftedArray (dupableRunSmallUnliftedArray# m) + +dupableRunSmallUnliftedArray# + :: (forall s. ST s (SmallMutableUnliftedArray s a)) + -> SmallUnliftedArray# (Unlifted a) +dupableRunSmallUnliftedArray# m = case Exts.runRW# $ \s -> + case unST m s of { (# s', SmallMutableUnliftedArray mary# #) -> + unsafeFreezeSmallUnliftedArray# mary# s'} of (# _, ary# #) -> ary# +{-# INLINE dupableRunSmallUnliftedArray# #-} + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (ST f) = f + +unsafeCreateSmallUnliftedArray + :: Int + -> (forall s. SmallMutableUnliftedArray s a -> ST s ()) + -> SmallUnliftedArray a +unsafeCreateSmallUnliftedArray !n f = runSmallUnliftedArray $ do + mary <- unsafeNewSmallUnliftedArray n + f mary + pure mary + +-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it +-- initializes all elements of the array as pointers to the empty array. Attempting +-- to read one of these elements before writing to it is in effect an unsafe +-- coercion from @'UnliftedArray' a@ to the element type. +unsafeNewSmallUnliftedArray + :: Int -- ^ size + -> ST s (SmallMutableUnliftedArray s a) +{-# inline unsafeNewSmallUnliftedArray #-} +unsafeNewSmallUnliftedArray (I# i) = ST $ \s -> case unsafeNewSmallUnliftedArray# i s of + (# s', ma #) -> (# s', SmallMutableUnliftedArray ma #) + + +-- | Creates a copy of a portion of a 'SmallUnliftedArray' +cloneSmallUnliftedArray + :: SmallUnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> SmallUnliftedArray a +{-# inline cloneSmallUnliftedArray #-} +cloneSmallUnliftedArray (SmallUnliftedArray ary) (I# off) (I# len) + = SmallUnliftedArray (cloneSmallUnliftedArray# ary off len) + +-- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of +-- another mutable array. +cloneSmallMutableUnliftedArray + :: SmallMutableUnliftedArray s a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> ST s (SmallMutableUnliftedArray s a) +{-# inline cloneSmallMutableUnliftedArray #-} +cloneSmallMutableUnliftedArray (SmallMutableUnliftedArray mary) (I# off) (I# len) + = ST $ \s -> case cloneSmallMutableUnliftedArray# mary off len s of + (# s', mary' #) -> (# s', SmallMutableUnliftedArray mary' #) + +emptySmallUnliftedArray :: SmallUnliftedArray_ unlifted_a a +emptySmallUnliftedArray = SmallUnliftedArray (emptySmallUnliftedArray# (##)) + +singletonSmallUnliftedArray :: PrimUnlifted a => a -> SmallUnliftedArray a +{-# INLINE singletonSmallUnliftedArray #-} +singletonSmallUnliftedArray x = runSmallUnliftedArray $ newSmallUnliftedArray 1 x + +concatSmallUnliftedArray :: SmallUnliftedArray a -> SmallUnliftedArray a -> SmallUnliftedArray a +{-# INLINE concatSmallUnliftedArray #-} +concatSmallUnliftedArray (SmallUnliftedArray a1) (SmallUnliftedArray a2) + = SmallUnliftedArray (concatSmallUnliftedArray# a1 a2) + +-- This junk is to make sure we unbox properly. Inlining this doesn't seem +-- likely to be much of a win ever, and could potentially lead to reboxing, +-- so we NOINLINE. It would be nice to find a prettier way to do this. +concatSmallUnliftedArray# :: SmallUnliftedArray# a -> SmallUnliftedArray# a -> SmallUnliftedArray# a +{-# NOINLINE concatSmallUnliftedArray# #-} +concatSmallUnliftedArray# a1 a2 = + let !sza1 = sizeofSmallUnliftedArray# a1 + in + if Exts.isTrue# (sza1 Exts.==# 0#) + then a2 + else + let !sza2 = sizeofSmallUnliftedArray# a2 + in + if Exts.isTrue# (sza2 Exts.==# 0#) + then a1 + else Exts.runRW# $ \s0 -> + let + finish s = + case unsafeNewSmallUnliftedArray# (sza1 Exts.+# sza2) s of { (# s', ma #) -> + case copySmallUnliftedArray# a1 0# ma 0# sza1 s' of { s'' -> + case copySmallUnliftedArray# a2 0# ma sza1 sza2 s'' of { s''' -> + case unsafeFreezeSmallUnliftedArray# ma s''' of + (# _, ar #) -> ar}}} + -- GHC wants to inline this, but I very much doubt it's worth the + -- extra code, considering that it calls multiple out-of-line + -- primops. + {-# NOINLINE finish #-} + in + -- When the final array will be "small", we tolerate the possibility that + -- it could be constructed multiple times in different threads. Currently, + -- "small" means fewer than 1000 elements. This is a totally arbitrary + -- cutoff that has not been tuned whatsoever. + if Exts.isTrue# ((sza1 Exts.+# sza2) Exts.>=# 1000#) + then finish (Exts.noDuplicate# s0) + else finish s0 + +foldrSmallUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> SmallUnliftedArray a -> b +{-# INLINE foldrSmallUnliftedArray #-} +foldrSmallUnliftedArray f z arr = go 0 + where + !sz = sizeofSmallUnliftedArray arr + go !i + | sz > i = f (indexSmallUnliftedArray arr i) (go (i+1)) + | otherwise = z + +-- | Strict right-associated fold over the elements of an 'SmallUnliftedArray. +{-# INLINE foldrSmallUnliftedArray' #-} +foldrSmallUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> SmallUnliftedArray a -> b +foldrSmallUnliftedArray' f z0 arr = go (sizeofSmallUnliftedArray arr - 1) z0 + where + go !i !acc + | i < 0 = acc + | otherwise = go (i - 1) (f (indexSmallUnliftedArray arr i) acc) + +-- | Lazy left-associated fold over the elements of an 'SmallUnliftedArray'. +{-# INLINE foldlSmallUnliftedArray #-} +foldlSmallUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> SmallUnliftedArray a -> b +foldlSmallUnliftedArray f z arr = go (sizeofSmallUnliftedArray arr - 1) + where + go !i + | i < 0 = z + | otherwise = f (go (i - 1)) (indexSmallUnliftedArray arr i) + +-- | Strict left-associated fold over the elements of an 'SmallUnliftedArray'. +{-# INLINE foldlSmallUnliftedArray' #-} +foldlSmallUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> SmallUnliftedArray a -> b +foldlSmallUnliftedArray' f z0 arr = go 0 z0 + where + !sz = sizeofSmallUnliftedArray arr + go !i !acc + | i < sz = go (i + 1) (f acc (indexSmallUnliftedArray arr i)) + | otherwise = acc + +-- | Strict effectful left-associated fold over the elements of an 'SmallUnliftedArray'. +{-# INLINE foldlSmallUnliftedArrayM' #-} +foldlSmallUnliftedArrayM' :: (PrimUnlifted a, Monad m) + => (b -> a -> m b) -> b -> SmallUnliftedArray a -> m b +foldlSmallUnliftedArrayM' f z0 arr = go 0 z0 + where + !sz = sizeofSmallUnliftedArray arr + go !i !acc + | i < sz = f acc (indexSmallUnliftedArray arr i) >>= go (i + 1) + | otherwise = pure acc + +-- | Effectfully traverse the elements of an 'SmallUnliftedArray', discarding +-- the resulting values. +{-# INLINE traverseSmallUnliftedArray_ #-} +traverseSmallUnliftedArray_ :: (PrimUnlifted a, Applicative m) + => (a -> m b) -> SmallUnliftedArray a -> m () +traverseSmallUnliftedArray_ f arr = go 0 + where + !sz = sizeofSmallUnliftedArray arr + go !i + | i < sz = f (indexSmallUnliftedArray arr i) *> go (i + 1) + | otherwise = pure () + +-- | Effectful indexed traversal of the elements of an 'SmallUnliftedArray', +-- discarding the resulting values. +{-# INLINE itraverseSmallUnliftedArray_ #-} +itraverseSmallUnliftedArray_ :: (PrimUnlifted a, Applicative m) + => (Int -> a -> m b) -> SmallUnliftedArray a -> m () +itraverseSmallUnliftedArray_ f arr = go 0 + where + !sz = sizeofSmallUnliftedArray arr + go !i + | i < sz = f i (indexSmallUnliftedArray arr i) *> go (i + 1) + | otherwise = pure () + +-- | Map over the elements of an 'SmallUnliftedArray'. +{-# INLINE mapSmallUnliftedArray #-} +mapSmallUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) + => (a -> b) + -> SmallUnliftedArray a + -> SmallUnliftedArray b +-- See Data.Primitive.Unlifted.Array.ST for discussion of the noDuplicate# +-- buried in this unsafeCreateSmallUnliftedArray. +mapSmallUnliftedArray f arr = unsafeCreateSmallUnliftedArray sz $ \marr -> do + let go !ix = if ix < sz + then do + let b = f (indexSmallUnliftedArray arr ix) + writeSmallUnliftedArray marr ix b + go (ix + 1) + else return () + go 0 + where + !sz = sizeofSmallUnliftedArray arr + +-- | Convert the unlifted array to a list. +{-# INLINE smallUnliftedArrayToList #-} +smallUnliftedArrayToList :: PrimUnlifted a => SmallUnliftedArray a -> [a] +smallUnliftedArrayToList xs = Exts.build (\c n -> foldrSmallUnliftedArray c n xs) + +smallUnliftedArrayFromList :: PrimUnlifted a => [a] -> SmallUnliftedArray a +smallUnliftedArrayFromList xs = smallUnliftedArrayFromListN (L.length xs) xs + +smallUnliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> SmallUnliftedArray a +smallUnliftedArrayFromListN len vs = unsafeCreateSmallUnliftedArray len run where + run :: forall s. SmallMutableUnliftedArray s a -> ST s () + run arr = do + let go :: [a] -> Int -> ST s () + go [] !ix = if ix == len + -- The size check is mandatory since failure to initialize all elements + -- introduces the possibility of a segfault happening when someone attempts + -- to read the unitialized element. See the docs for unsafeNewSmallUnliftedArray. + then return () + else die "unliftedArrayFromListN" "list length less than specified size" + go (a : as) !ix = if ix < len + then do + writeSmallUnliftedArray arr ix a + go as (ix + 1) + else die "unliftedArrayFromListN" "list length greater than specified size" + go vs 0 + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) + => Exts.IsList (SmallUnliftedArray_ unlifted_a a) where + type Item (SmallUnliftedArray_ _ a) = a + fromList = smallUnliftedArrayFromList + fromListN = smallUnliftedArrayFromListN + toList = smallUnliftedArrayToList + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) + => Semigroup (SmallUnliftedArray_ unlifted_a a) where + (<>) = concatSmallUnliftedArray + +instance (PrimUnlifted a, unlifted_a ~ Unlifted a) => Monoid (SmallUnliftedArray_ unlifted_a a) where + mempty = emptySmallUnliftedArray + +instance (Show a, PrimUnlifted a, unlifted_a ~ Unlifted a) => Show (SmallUnliftedArray_ unlifted_a a) where + showsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofSmallUnliftedArray a) . showString " " + . shows (smallUnliftedArrayToList a) + +instance unlifted_a ~ Unlifted a => Eq (SmallMutableUnliftedArray_ unlifted_a s a) where + (==) = sameSmallMutableUnliftedArray + +instance (Eq a, PrimUnlifted a, unlifted_a ~ Unlifted a) => Eq (SmallUnliftedArray_ unlifted_a a) where + aa1 == aa2 = sizeofSmallUnliftedArray aa1 == sizeofSmallUnliftedArray aa2 + && loop (sizeofSmallUnliftedArray aa1 - 1) + where + loop i + | i < 0 = True + | otherwise = indexSmallUnliftedArray aa1 i == indexSmallUnliftedArray aa2 i && loop (i-1) + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.Unlifted.SmallArray.ST." ++ fun ++ ": " ++ problem diff --git a/src/Data/Primitive/Unlifted/Type.hs b/src/Data/Primitive/Unlifted/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Type.hs @@ -0,0 +1,15 @@ +{-# language CPP #-} + +module Data.Primitive.Unlifted.Type + ( UnliftedType + ) where + +#if !MIN_VERSION_base(4,16,0) +import GHC.Exts (TYPE, RuntimeRep(UnliftedRep)) +#else +import GHC.Exts (UnliftedType) +#endif + +#if !MIN_VERSION_base(4,16,0) +type UnliftedType = TYPE 'UnliftedRep +#endif diff --git a/src/Data/Primitive/Unlifted/Weak.hs b/src/Data/Primitive/Unlifted/Weak.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Weak.hs @@ -0,0 +1,146 @@ +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} + +-- | "System.Mem.Weak" provides weak references from lifted keys to lifted +-- values. "Data.IORef", "Control.Concurrent.MVar", and +-- @Control.Concurrent.STM.TVar@ provide operations for producing weak +-- references from unlifted keys /of specific types/ to lifted values. +-- +-- This module fills in the gaps. It offers a type ('UnliftedWeak') for weak +-- references from (lifted or unlifted) keys to unlifted values. It also +-- provides fully general operations for producing weak references from +-- unlifted keys to lifted values. +-- +-- Usage note: Weak references /from/ lifted types can be fragile in the face +-- of GHC's unboxing optimizations. Weak references from unlifted types are +-- much more reliable. Weak references /to/ boxed types that wrap unlifted +-- types tend to be inefficient, because they keep not only the actual value +-- alive but also its box. Unless it's necessary to create a 'SMW.Weak' +-- reference to an unevaluated thunk, it's generally best to create an +-- 'UnliftedWeak' reference to the unlifted value instead. +module Data.Primitive.Unlifted.Weak + ( UnliftedWeak_ (..) + , UnliftedWeak + , mkWeakFromUnliftedToUnlifted + , mkWeakToUnlifted + , mkWeakFromUnlifted + , deRefUnliftedWeak + , finalizeUnlifted + , mkUnliftedWeakPtr + , addFinalizerUnlifted + , addCFinalizerToUnliftedWeak1 + , addCFinalizerToUnliftedWeak2 + , touchUnlifted + ) where +import Control.Monad.Primitive (PrimMonad,PrimState,ioToPrim) +import GHC.Exts (RealWorld) +import Data.Primitive.Unlifted.Class (PrimUnlifted) +import Data.Primitive.Unlifted.Weak.IO (UnliftedWeak_ (..), UnliftedWeak) +import qualified Data.Primitive.Unlifted.Weak.IO as W +import qualified System.Mem.Weak as SMW +import Foreign.Ptr (Ptr, FunPtr) + +-- | Establishes a weak pointer from an unlifted value @k@ to an +-- unlifted value @v@ with an optional finalizer. +mkWeakFromUnliftedToUnlifted + :: (PrimUnlifted k, PrimUnlifted v, PrimMonad m, PrimState m ~ RealWorld) + => k -> v -> Maybe (IO ()) -> m (UnliftedWeak v) +{-# INLINE mkWeakFromUnliftedToUnlifted #-} +-- Why do we insist on an IO argument and not just a PrimBase one? +-- No particular reason. But that seems likely to make the type +-- harder to read without much practical benefit. Users can always use +-- primToIO if necessary to write their finalizers. +mkWeakFromUnliftedToUnlifted k v mf = ioToPrim $ W.mkWeakFromUnliftedToUnlifted k v mf + +-- | Establishes a weak pointer from a lifted value @k@ to an +-- unlifted value @v@ with an optional finalizer. +mkWeakToUnlifted + :: (PrimUnlifted v, PrimMonad m, PrimState m ~ RealWorld) + => k -> v -> Maybe (IO ()) -> m (UnliftedWeak v) +{-# INLINE mkWeakToUnlifted #-} +mkWeakToUnlifted k v mf = ioToPrim $ W.mkWeakToUnlifted k v mf + +-- | Establishes a weak pointer from an unlifted value @k@ to a +-- lifted value @v@ with an optional finalizer. +mkWeakFromUnlifted + :: (PrimUnlifted k, PrimMonad m, PrimState m ~ RealWorld) + => k -> v -> Maybe (IO ()) -> m (SMW.Weak v) +{-# INLINE mkWeakFromUnlifted #-} +mkWeakFromUnlifted k v mf = ioToPrim $ W.mkWeakFromUnlifted k v mf + +-- | Derefences a weak pointer. If the key is still alive and the +-- pointer has not been finalized with 'finalizeUnlifted', then +-- @Just v@ is returned, where @v@ is the /value/ in the weak +-- pointer. Otherwise, @Nothing@ is returned. +deRefUnliftedWeak + :: (PrimUnlifted v, PrimMonad m, PrimState m ~ RealWorld) + => UnliftedWeak v -> m (Maybe v) +{-# INLINE deRefUnliftedWeak #-} +deRefUnliftedWeak w = ioToPrim $ W.deRefUnliftedWeak w + +-- | Immediately finalize a weak pointer. +finalizeUnlifted + :: (PrimMonad m, PrimState m ~ RealWorld) + => UnliftedWeak v -> m () +{-# INLINE finalizeUnlifted #-} +finalizeUnlifted w = ioToPrim $ W.finalizeUnlifted w + +-- | Make a weak pointer from an unlifted value to itself. +-- +-- Note: This should generally be preferred to @Data.IORef.mkWeakIORef@ +-- and similar for making weak pointers to @IORef@s, @MVar@s, @TVar@s, +-- etc, as the values are stored more directly and compactly this way. +mkUnliftedWeakPtr + :: (PrimUnlifted k, PrimMonad m, PrimState m ~ RealWorld) + => k -> Maybe (IO ()) -> m (UnliftedWeak k) +{-# INLINE mkUnliftedWeakPtr #-} +mkUnliftedWeakPtr k fin = ioToPrim $ W.mkUnliftedWeakPtr k fin + +-- | A specialised version of @mkUnliftedWeakPtr@, where the @UnliftedWeak@ +-- object returned is simply thrown away (however the finalizer will be +-- remembered by the garbage collector, and will still be run when the key +-- becomes unreachable). +addFinalizerUnlifted + :: (PrimUnlifted k, PrimMonad m, PrimState m ~ RealWorld) + => k -> IO () -> m () +{-# INLINE addFinalizerUnlifted #-} +addFinalizerUnlifted k fin = ioToPrim $ W.addFinalizerUnlifted k fin + +-- | Add a finalizer written in C to an 'UnliftedWeak'. Takes a pointer to a C +-- function of one argument and an argument to call it with. Returns 'True' +-- on success, or 'False' if the 'UnliftedWeak' is already dead. +addCFinalizerToUnliftedWeak1 + :: (PrimMonad m, PrimState m ~ RealWorld) + => FunPtr (a -> IO ()) -> Ptr a -> UnliftedWeak b -> m Bool +{-# INLINE addCFinalizerToUnliftedWeak1 #-} +addCFinalizerToUnliftedWeak1 f a w = ioToPrim $ W.addCFinalizerToUnliftedWeak1 f a w + +-- | Add a finalizer written in C to an 'UnliftedWeak'. Takes a pointer to a C +-- function of two arguments and arguments to call it with. Returns 'True' +-- on success, or 'False' if the 'UnliftedWeak' is already dead. +addCFinalizerToUnliftedWeak2 + :: (PrimMonad m, PrimState m ~ RealWorld) + => FunPtr (a -> b -> IO ()) -> Ptr a -> Ptr b -> UnliftedWeak c -> m Bool +{-# INLINE addCFinalizerToUnliftedWeak2 #-} +addCFinalizerToUnliftedWeak2 f a b w = ioToPrim $ W.addCFinalizerToUnliftedWeak2 f a b w + +-- | Ensure that a value is considered live by the garbage collector at a +-- particular point in the program. Typically, this is used to prevent foreign +-- resources from being finalized while they are still being used. +-- +-- Considerable care is required when using this operation (see GHC ticket +-- 14346). In particular, if GHC sees that an action @m@ will never complete +-- normally, then it will simplify @m >> touchUnlifted a@ to @m@, allowing @a@ +-- to die prematurely. For now, functions using @touchUnlifted@ may require +-- careful use of @NOINLINE@ to work around this; in the future, GHC will +-- probably provide a more robust operation for keeping values alive. +touchUnlifted + :: (PrimUnlifted a, PrimMonad m, PrimState m ~ RealWorld) + => a -> m () +touchUnlifted a = ioToPrim $ W.touchUnlifted a diff --git a/src/Data/Primitive/Unlifted/Weak/IO.hs b/src/Data/Primitive/Unlifted/Weak/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Weak/IO.hs @@ -0,0 +1,172 @@ +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language DataKinds #-} + +-- | A version of "Data.Primitive.Unlifted.Weak" specialized to the 'IO' type. +module Data.Primitive.Unlifted.Weak.IO + ( UnliftedWeak_ (..) + , UnliftedWeak + , mkWeakFromUnliftedToUnlifted + , mkWeakToUnlifted + , mkWeakFromUnlifted + , deRefUnliftedWeak + , finalizeUnlifted + , mkUnliftedWeakPtr + , addFinalizerUnlifted + , addCFinalizerToUnliftedWeak1 + , addCFinalizerToUnliftedWeak2 + , touchUnlifted + ) where + +import GHC.Exts ( mkWeak#, mkWeakNoFinalizer# ) +import Data.Primitive.Unlifted.Class (PrimUnlifted (..)) +import Data.Primitive.Unlifted.Weak.Primops +import GHC.IO (IO (..)) +import qualified GHC.Weak +import GHC.Ptr (Ptr (..), FunPtr (..)) +import qualified GHC.Exts as Exts + +import Data.Primitive.Unlifted.Type + +-- | A weak pointer from a key (which may be lifted or unlifted) +-- to an unlifted value. In @UnliftedWeak_ a unlifted_a@, it is generally +-- expected that @unlifted_a ~ 'Unlifted' a@, but enforcing that here +-- would lead to unfortunate type roles. See "System.Mem.Weak" for detailed +-- information about weak references, including the notes at the end of that +-- module. +data UnliftedWeak_ a (unlifted_a :: UnliftedType) = UnliftedWeak (UnliftedWeak# unlifted_a) +type role UnliftedWeak_ phantom representational + +-- | A type synonym for an 'UnliftedWeak_' containing lifted values of +-- a particular type. As a general rule, this type synonym should not be used in +-- class instances—use 'UnliftedWeak_' with an equality constraint instead. +-- It also should not be used when defining newtypes or datatypes, unless those +-- will have restrictive type roles regardless—use 'UnliftedWeak_' instead. +type UnliftedWeak a = UnliftedWeak_ a (Unlifted a) + +instance unlifted_a ~ Unlifted a => PrimUnlifted (UnliftedWeak_ a unlifted_a) where + {-# INLINE toUnlifted# #-} + {-# INLINE fromUnlifted# #-} + type Unlifted (UnliftedWeak_ _ unlifted_a) = UnliftedWeak# unlifted_a + toUnlifted# (UnliftedWeak w) = w + fromUnlifted# w = UnliftedWeak w + +-- | Establishes a weak pointer from an unlifted value @k@ to an +-- unlifted value @v@ with an optional finalizer. +mkWeakFromUnliftedToUnlifted + :: (PrimUnlifted k, PrimUnlifted v) + => k -> v -> Maybe (IO ()) -> IO (UnliftedWeak v) +{-# INLINE mkWeakFromUnliftedToUnlifted #-} +mkWeakFromUnliftedToUnlifted k v (Just (IO finalizer)) = IO $ \s -> + case mkWeakFromUnliftedToUnlifted# (toUnlifted# k) (toUnlifted# v) finalizer s of + (# s', w #) -> (# s', UnliftedWeak w #) +mkWeakFromUnliftedToUnlifted k v Nothing = IO $ \s -> + case mkWeakFromUnliftedToUnliftedNoFinalizer# (toUnlifted# k) (toUnlifted# v) s of + (# s', w #) -> (# s', UnliftedWeak w #) + +-- | Establishes a weak pointer from a lifted value @k@ to an +-- unlifted value @v@ with an optional finalizer. +mkWeakToUnlifted + :: PrimUnlifted v + => k -> v -> Maybe (IO ()) -> IO (UnliftedWeak v) +{-# INLINE mkWeakToUnlifted #-} +mkWeakToUnlifted k v (Just (IO finalizer)) = IO $ \s -> + case mkWeakToUnlifted# k (toUnlifted# v) finalizer s of + (# s', w #) -> (# s', UnliftedWeak w #) +mkWeakToUnlifted k v Nothing = IO $ \s -> + case mkWeakToUnliftedNoFinalizer# k (toUnlifted# v) s of + (# s', w #) -> (# s', UnliftedWeak w #) + +-- | Establishes a weak pointer from an unlifted value @k@ to a +-- lifted value @v@ with an optional finalizer. +mkWeakFromUnlifted + :: PrimUnlifted k + => k -> v -> Maybe (IO ()) -> IO (GHC.Weak.Weak v) +{-# INLINE mkWeakFromUnlifted #-} +mkWeakFromUnlifted k v (Just (IO finalizer)) = IO $ \s -> + case mkWeak# (toUnlifted# k) v finalizer s of + (# s', w #) -> (# s', GHC.Weak.Weak w #) +mkWeakFromUnlifted k v Nothing = IO $ \s -> + case mkWeakNoFinalizer# (toUnlifted# k) v s of + (# s', w #) -> (# s', GHC.Weak.Weak w #) + +-- | Derefences a weak pointer. If the key is still alive and the +-- pointer has not been finalized with 'finalizeUnlifted', then +-- @Just v@ is returned, where @v@ is the /value/ in the weak +-- pointer. Otherwise, @Nothing@ is returned. +deRefUnliftedWeak :: PrimUnlifted v => UnliftedWeak v -> IO (Maybe v) +{-# INLINE deRefUnliftedWeak #-} +deRefUnliftedWeak (UnliftedWeak w) = IO $ \s -> + case deRefUnliftedWeak# w s of + (# s', res #) -> case res of + (# (# #) | #) -> (# s', Nothing #) + (# | p #) -> (# s', Just (fromUnlifted# p) #) + +-- | Immediately finalize a weak pointer. +finalizeUnlifted :: UnliftedWeak v -> IO () +{-# INLINE finalizeUnlifted #-} +finalizeUnlifted (UnliftedWeak w) = IO $ \s -> + case finalizeUnliftedWeak# w s of + (# s', (# (# #) | #) #) -> (# s', () #) -- already dead, or no finalizer + (# s', (# | f #) #) -> f s' + +-- | Make a weak pointer from an unlifted value to itself. +-- +-- Note: This should generally be preferred to @Data.IORef.mkWeakIORef@ +-- and similar for making weak pointers to @IORef@s, @MVar@s, @TVar@s, +-- etc, as the values are stored more directly and compactly this way. +mkUnliftedWeakPtr :: PrimUnlifted k => k -> Maybe (IO ()) -> IO (UnliftedWeak k) +{-# INLINE mkUnliftedWeakPtr #-} +mkUnliftedWeakPtr k fin = mkWeakFromUnliftedToUnlifted k k fin + +-- | A specialised version of @mkUnliftedWeakPtr@, where the @UnliftedWeak@ +-- object returned is simply thrown away (however the finalizer will be +-- remembered by the garbage collector, and will still be run when the key +-- becomes unreachable). +addFinalizerUnlifted :: PrimUnlifted k => k -> IO () -> IO () +{-# INLINE addFinalizerUnlifted #-} +addFinalizerUnlifted k fin = do + _ <- mkUnliftedWeakPtr k (Just fin) -- throw it away + pure () + +-- | Add a finalizer written in C to an 'UnliftedWeak'. Takes a pointer to a C +-- function of one argument and an argument to call it with. Returns 'True' +-- on success, or 'False' if the 'UnliftedWeak' is already dead. +addCFinalizerToUnliftedWeak1 :: FunPtr (a -> IO ()) -> Ptr a -> UnliftedWeak b -> IO Bool +{-# INLINE addCFinalizerToUnliftedWeak1 #-} +addCFinalizerToUnliftedWeak1 (FunPtr f) (Ptr a) (UnliftedWeak w) = + IO $ \s -> case addCFinalizerToUnliftedWeak1# f a w s of + (# s', 0# #) -> (# s', False #) + (# s', _ #) -> (# s', True #) + +-- | Add a finalizer written in C to an 'UnliftedWeak'. Takes a pointer to a C +-- function of two arguments and arguments to call it with. Returns 'True' +-- on success, or 'False' if the 'UnliftedWeak' is already dead. +addCFinalizerToUnliftedWeak2 :: FunPtr (a -> b -> IO ()) -> Ptr a -> Ptr b -> UnliftedWeak c -> IO Bool +{-# INLINE addCFinalizerToUnliftedWeak2 #-} +addCFinalizerToUnliftedWeak2 (FunPtr f) (Ptr a) (Ptr b) (UnliftedWeak w) = + IO $ \s -> case addCFinalizerToUnliftedWeak2# f a b w s of + (# s', 0# #) -> (# s', False #) + (# s', _ #) -> (# s', True #) + +-- | Ensure that a value is considered live by the garbage collector at a +-- particular point in the program. Typically, this is used to prevent foreign +-- resources from being finalized while they are still being used. +-- +-- Considerable care is required when using this operation (see GHC ticket +-- 14346). In particular, if GHC sees that an action @m@ will never complete +-- normally, then it will simplify @m >> touchUnlifted a@ to @m@, allowing @a@ +-- to die prematurely. For now, functions using @touchUnlifted@ may require +-- careful use of @NOINLINE@ to work around this; in the future, GHC will +-- probably provide a more robust operation for keeping values alive. +touchUnlifted + :: PrimUnlifted a + => a -> IO () +touchUnlifted a = IO $ \s -> + (# Exts.touch# (toUnlifted# a) s, () #) diff --git a/src/Data/Primitive/Unlifted/Weak/Primops.hs b/src/Data/Primitive/Unlifted/Weak/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Unlifted/Weak/Primops.hs @@ -0,0 +1,129 @@ +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language UnboxedSums #-} +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language RoleAnnotations #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language UnliftedNewtypes #-} + +-- | "Primops" for weak references from (lifted or unlifted) values +-- to unlifted values. Several of these use a slightly different +-- interface than the underlying GHC primops. I have a GHC proposal +-- in progress (https://github.com/ghc-proposals/ghc-proposals/pull/367) +-- to make GHC match this interface. Note that the GHC primops work +-- just fine with unlifted types as /keys/, so we only need to fake +-- our own to use unlifted types as /values/. +module Data.Primitive.Unlifted.Weak.Primops + ( UnliftedWeak# + , mkWeakFromUnliftedToUnlifted# + , mkWeakFromUnliftedToUnliftedNoFinalizer# + , mkWeakToUnlifted# + , mkWeakToUnliftedNoFinalizer# + , addCFinalizerToUnliftedWeak1# + , addCFinalizerToUnliftedWeak2# + , deRefUnliftedWeak# + , finalizeUnliftedWeak# + ) where +import Data.Coerce (coerce) +import GHC.Exts + ( RealWorld, State# + , Weak#, mkWeak#, mkWeakNoFinalizer#, deRefWeak#, finalizeWeak#, Addr# + , Int#, nullAddr#, addCFinalizerToWeak#) + +import Data.Primitive.Unlifted.Type + +-- | A weak pointer from a key (which may be lifted or unlifted) +-- to an unlifted value. +newtype UnliftedWeak# (a :: UnliftedType) = UnliftedWeak# (Weak# a) +type role UnliftedWeak# representational + +-- The primops in GHC.Prim are "open kinded". They don't care if the +-- key is lifted or unlifted. But that sort of magic isn't available +-- to us, so we use separate primops for lifted and unlifted keys. + +-- | @mkWeakFromUnliftedToUnlifted# k v finalizer s@ creates a weak reference +-- from an unlifted value @k@ to some unlifted value @v@. If @k@ is still alive +-- then @v@ can be retrieved using @deRefUnliftedWeak#@. +mkWeakFromUnliftedToUnlifted# + :: forall (k :: UnliftedType) (v :: UnliftedType) c. + k -> v -> (State# RealWorld -> (# State# RealWorld, c #)) + -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #) +{-# INLINE mkWeakFromUnliftedToUnlifted# #-} +mkWeakFromUnliftedToUnlifted# k v finalizer s = coerce (mkWeak# k v finalizer s) + +-- | The same as 'mkWeakFromUnliftedToUnlifted#' but without a finalizer. +mkWeakFromUnliftedToUnliftedNoFinalizer# + :: forall (k :: UnliftedType) (v :: UnliftedType). + k -> v -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #) +{-# INLINE mkWeakFromUnliftedToUnliftedNoFinalizer# #-} +mkWeakFromUnliftedToUnliftedNoFinalizer# k v s = coerce (mkWeakNoFinalizer# k v s) + +-- | @mkWeakToUnlifted# k v finalizer s@ creates a weak reference from a lifted +-- value @k@ to some unlifted value @v@. If @k@ is still alive then @v@ can be +-- retrieved using @deRefUnliftedWeak#@. +mkWeakToUnlifted# + :: forall k (v :: UnliftedType) c. + k -> v -> (State# RealWorld -> (# State# RealWorld, c #)) + -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #) +{-# INLINE mkWeakToUnlifted# #-} +mkWeakToUnlifted# k v finalizer s = coerce (mkWeak# k v finalizer s) + +-- | The same as 'mkWeakToUnlifted#' but without a finalizer. +mkWeakToUnliftedNoFinalizer# + :: forall k (v :: UnliftedType). + k -> v -> State# RealWorld -> (# State# RealWorld, UnliftedWeak# v #) +{-# INLINE mkWeakToUnliftedNoFinalizer# #-} +mkWeakToUnliftedNoFinalizer# k v s = coerce (mkWeakNoFinalizer# k v s) + +-- | @addCFinalizerToUnliftedWeak1# fptr ptr w@ attaches a C function pointer +-- @fptr@ to a weak pointer @w@ as a finalizer. @ptr@ is an argument to be +-- passed to @fptr@. @addCFinalizerToWeak1#@ returns @1#@ on success, or @0#@ +-- if @w@ is already dead. +addCFinalizerToUnliftedWeak1# :: Addr# -> Addr# -> UnliftedWeak# b -> State# RealWorld -> (# State# RealWorld, Int# #) +{-# INLINE addCFinalizerToUnliftedWeak1# #-} +addCFinalizerToUnliftedWeak1# fptr ptr (UnliftedWeak# w) + = addCFinalizerToWeak# fptr ptr 0# nullAddr# w + +-- | @addCFinalizerToUnliftedWeak2# fptr eptr ptr w@ attaches a C function +-- pointer @fptr@ to a weak pointer @w@ as a finalizer. @eptr@ and @ptr@ are +-- arguments which will be passed to @fptr@ in order. @addCFinalizerToWeak2#@ +-- returns @1#@ on success, or @0#@ if @w@ is already dead. +addCFinalizerToUnliftedWeak2# :: Addr# -> Addr# -> Addr# -> UnliftedWeak# b -> State# RealWorld -> (# State# RealWorld, Int# #) +{-# INLINE addCFinalizerToUnliftedWeak2# #-} +-- Note: the underlying primop takes the function arguments in *reverse* order. +-- We fix that up here. +addCFinalizerToUnliftedWeak2# fptr eptr ptr (UnliftedWeak# w) + = addCFinalizerToWeak# fptr ptr 1# eptr w + +-- | Dereference an 'UnliftedWeak#'. If the pointer is already dead, returns +-- @(#(##) | #)@. Otherwise returns @(# | v #)@, where @v@ is the target of +-- the weak pointer. +deRefUnliftedWeak# + :: UnliftedWeak# v + -> State# RealWorld + -> (# State# RealWorld, (# (##) | v #) #) +{-# INLINE deRefUnliftedWeak# #-} +deRefUnliftedWeak# (UnliftedWeak# w) s = + case deRefWeak# w s of + (# s', flag, p #) -> case flag of + 0# -> (# s', (# (##) | #) #) + _ -> (# s', (# | p #) #) + +-- | @finalizeUnliftedWeak#@ attempts to finalize an 'UnliftedWeak#'. If the +-- weak pointer is already dead, or it has no Haskell finalizer, it returns +-- @(#(##) | #)@. Otherwise, it returns @(# | f #)@, where @f@ is the Haskell +-- finalization action. The return value @b@ from the finalizer should be +-- ignored. @finalizeUnliftedWeak#@ breaks the connection the @UnliftedWeak#@ +-- has maintained between key and value and runs any C finalizers. After +-- finalization, @deRefUnliftedWeak#@ will return @(#(##) | #)@. +finalizeUnliftedWeak# + :: UnliftedWeak# v + -> State# RealWorld + -> (# State# RealWorld, (# (##) | State# RealWorld -> (# State# RealWorld, b #) #) #) +{-# INLINE finalizeUnliftedWeak# #-} +finalizeUnliftedWeak# (UnliftedWeak# w) s = + case finalizeWeak# w s of + (# s', 0#, _ #) -> (# s', (# (##) | #) #) -- already dead, or no Haskell finalizer + (# s', _, f #) -> (# s', (# | f #) #) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeInType #-} + +import Control.Monad.ST +import Data.Primitive +import Data.Primitive.Unlifted.Array +import Data.Primitive.Unlifted.Class +import Data.Proxy (Proxy(..)) +import Data.Word +import GHC.Exts (fromList) +import GHC.Int +import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,CoArbitrary,Function) +import Test.Tasty (defaultMain,testGroup,TestTree) + +import qualified Data.List as L +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Classes.Base as QCC +import qualified Test.QuickCheck.Classes.Base.IsList as QCCL +import qualified Test.Tasty.QuickCheck as TQC + +main :: IO () +main = defaultMain $ testGroup "properties" + [ testGroup "UnliftedArray" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray) + , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray) + , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray') + , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray) + , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray') + ] + ] + +arrInt16 :: Proxy (PrimArray Int16) +arrInt16 = Proxy + +arrInt32 :: Proxy (PrimArray Int16) +arrInt32 = Proxy + +lawsToTest :: QCC.Laws -> TestTree +lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) + +instance Arbitrary1 Array where + liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen) + +instance Arbitrary a => Arbitrary (Array a) where + arbitrary = fmap fromList QC.arbitrary + +instance Arbitrary1 SmallArray where + liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen) + +instance Arbitrary a => Arbitrary (SmallArray a) where + arbitrary = fmap smallArrayFromList QC.arbitrary + +instance Arbitrary ByteArray where + arbitrary = do + xs <- QC.arbitrary :: Gen [Word8] + return $ runST $ do + a <- newByteArray (L.length xs) + iforM_ xs $ \ix x -> do + writeByteArray a ix x + unsafeFreezeByteArray a + +instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where + arbitrary = do + xs <- QC.arbitrary :: Gen [a] + return $ runST $ do + a <- newPrimArray (L.length xs) + iforM_ xs $ \ix x -> do + writePrimArray a ix x + unsafeFreezePrimArray a + +instance (Arbitrary b, PrimUnlifted b, Unlifted b ~ a) => Arbitrary (UnliftedArray_ a b) where + arbitrary = do + xs <- QC.vector =<< QC.choose (0,3) + return (unliftedArrayFromList xs) + +instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where + coarbitrary x = QC.coarbitrary (primArrayToList x) + +instance (Prim a, Function a) => Function (PrimArray a) where + function = QC.functionMap primArrayToList primArrayFromList + +iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m () +iforM_ xs0 f = go 0 xs0 where + go !_ [] = return () + go !ix (x : xs) = f ix x >> go (ix + 1) xs diff --git a/test/Unit.hs b/test/Unit.hs deleted file mode 100644 --- a/test/Unit.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = pure ()