packages feed

primitive-unlifted 0.1.3.1 → 2.2.0.0

raw patch · 23 files changed

Files

CHANGELOG.md view
@@ -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`.
primitive-unlifted.cabal view
@@ -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
+ src/Data/Primitive/TArray/Classic.hs view
@@ -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)
src/Data/Primitive/Unlifted/Array.hs view
@@ -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
+ src/Data/Primitive/Unlifted/Array/Primops.hs view
@@ -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# #-}
+ src/Data/Primitive/Unlifted/Array/ST.hs view
@@ -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
+ src/Data/Primitive/Unlifted/Box.hs view
@@ -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
src/Data/Primitive/Unlifted/Class.hs view
@@ -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
+ src/Data/Primitive/Unlifted/MVar.hs view
@@ -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)
+ src/Data/Primitive/Unlifted/MVar/Primops.hs view
@@ -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
+ src/Data/Primitive/Unlifted/MVar/ST.hs view
@@ -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'
+ src/Data/Primitive/Unlifted/MutVar.hs view
@@ -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
+ src/Data/Primitive/Unlifted/MutVar/Primops.hs view
@@ -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 #) }
+ src/Data/Primitive/Unlifted/MutVar/ST.hs view
@@ -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 #)
+ src/Data/Primitive/Unlifted/SmallArray.hs view
@@ -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
+ src/Data/Primitive/Unlifted/SmallArray/Primops.hs view
@@ -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# #-}
+ src/Data/Primitive/Unlifted/SmallArray/ST.hs view
@@ -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
+ src/Data/Primitive/Unlifted/Type.hs view
@@ -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
+ src/Data/Primitive/Unlifted/Weak.hs view
@@ -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
+ src/Data/Primitive/Unlifted/Weak/IO.hs view
@@ -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, () #)
+ src/Data/Primitive/Unlifted/Weak/Primops.hs view
@@ -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 #) #)
+ test/Main.hs view
@@ -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
− test/Unit.hs 
@@ -1,2 +0,0 @@-main :: IO ()-main = pure ()