Skip to content

Commit 7045d6c

Browse files
BebeSparkelSparkelBebeSparkelSparkel
committed
added Mutable Primiative Arrays
1 parent 76dc63e commit 7045d6c

4 files changed

Lines changed: 117 additions & 45 deletions

File tree

‎mutable-containers/mutable-containers.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 1.12
22

3-
-- This file has been generated from package.yaml by hpack version 0.34.7.
3+
-- This file has been generated from package.yaml by hpack version 0.36.0.
44
--
55
-- see: https://github.com/sol/hpack
66

@@ -28,6 +28,7 @@ library
2828
exposed-modules:
2929
Data.Mutable
3030
other-modules:
31+
Data.Mutable.Array
3132
Data.Mutable.BRef
3233
Data.Mutable.Class
3334
Data.Mutable.Deque

‎mutable-containers/src/Data/Mutable.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -34,13 +34,15 @@ module Data.Mutable
3434
, asBDeque
3535
, DLList
3636
, asDLList
37+
, Array (..)
38+
, ArrayMemoryProperties (..)
3739
-- * Type classes
3840
, MutableContainer (..)
3941
, MutableRef (..)
4042
, MutableAtomicRef (..)
4143
, MutableCollection (..)
42-
, MutableInitialSizedCollection (..)
43-
, MutableIndexing (..)
44+
, MutableAllocatedCollection (..)
45+
, MutableIndexingWrite (..)
4446
, MutablePushFront (..)
4547
, MutablePushBack (..)
4648
, MutablePopFront (..)
@@ -65,6 +67,7 @@ import Data.Mutable.PRef
6567
import Data.Mutable.BRef
6668
import Data.Mutable.Deque
6769
import Data.Mutable.DLList
70+
import Data.Mutable.Array
6871
import Data.Vector.Unboxed (Unbox)
6972
import Data.Primitive (Prim)
7073
import Data.Vector.Storable (Storable)

‎mutable-containers/src/Data/Mutable/Array.hs‎

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE KindSignatures #-}
2+
{-# LANGUAGE ConstraintKinds #-}
3+
{-# LANGUAGE UndecidableInstances #-}
4+
{-# LANGUAGE DataKinds #-}
5+
{-# LANGUAGE TypeFamilies #-}
6+
{-# LANGUAGE TypeOperators #-}
7+
{-# LANGUAGE StandaloneKindSignatures #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE TypeApplications #-}
10+
{-# LANGUAGE FlexibleInstances #-}
11+
{-# LANGUAGE FlexibleContexts #-}
12+
module Data.Mutable.Array
13+
( Array (..)
14+
, ArrayMemoryProperties (..)
15+
) where
16+
17+
import Data.Mutable.Class
18+
import Data.Word
19+
import GHC.TypeLits
20+
import Data.Kind (Constraint)
21+
import Data.Proxy (Proxy(Proxy))
22+
import Unsafe.Coerce (unsafeCoerce)
23+
import Control.Monad.Primitive
24+
25+
import Data.Primitive.ByteArray (MutableByteArray, newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, writeByteArray)
26+
import Data.Primitive.Types (Prim)
27+
28+
newtype Array (p :: ArrayMemoryProperties) e s = Array (MutableByteArray s)
29+
30+
data ArrayMemoryProperties = Regular | Pinned | AlignedPinned Nat
31+
32+
instance MutableContainer (Array p e s) where
33+
type MCState (Array p e s) = s
34+
35+
instance MutableCollection (Array Regular e s) where
36+
type CollElement (Array Regular e s) = e
37+
newColl = coerceToArray $ newByteArray 0
38+
instance MutableCollection (Array Pinned e s) where
39+
type CollElement (Array Pinned e s) = e
40+
newColl = coerceToArray $ newPinnedByteArray 0
41+
instance KnownNat n => MutableCollection (Array (AlignedPinned n) e s) where
42+
type CollElement (Array (AlignedPinned n) e s) = e
43+
newColl = coerceToArray $ newAlignedPinnedByteArray 0 alignment
44+
where
45+
alignment = fromIntegral $ natVal $ Proxy @n
46+
47+
type instance CollIndex (Array _ _ _) = Int
48+
instance MutableAllocatedCollection (Array Regular e s) where
49+
newCollOfSize = coerceToArray . newByteArray
50+
{-# INLINE newCollOfSize #-}
51+
instance MutableAllocatedCollection (Array Pinned e s) where
52+
newCollOfSize = coerceToArray . newPinnedByteArray
53+
{-# INLINE newCollOfSize #-}
54+
instance KnownNat n => MutableAllocatedCollection (Array (AlignedPinned n) e s) where
55+
newCollOfSize = coerceToArray . flip newAlignedPinnedByteArray alignment
56+
where
57+
alignment = fromIntegral $ natVal $ Proxy @n
58+
{-# INLINE newCollOfSize #-}
59+
60+
coerceToArray :: m (MutableByteArray s) -> m (Array p e s)
61+
coerceToArray = unsafeCoerce
62+
63+
instance (Prim (CollElement (Array p e s)), MutableAllocatedCollection (Array p e s)) => MutableIndexingWrite (Array p e s) where
64+
writeIndex (Array c) i x = writeByteArray c i x
65+
66+
type IsPow2 :: Nat -> Constraint
67+
type IsPow2 x = IsPow2' (Mod x 2) x
68+
type IsPow2' :: Nat -> Nat -> Constraint
69+
type family IsPow2' m x where
70+
IsPow2' _ 2 = ()
71+
IsPow2' 1 x = TypeError (ShowType x :<>: Text " is not a power of 2.")
72+
IsPow2' 0 x = IsPow2' 0 (Div x 2)

‎mutable-containers/src/Data/Mutable/Class.hs‎

Lines changed: 38 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -20,8 +20,9 @@ module Data.Mutable.Class
2020
, MutableRef (..)
2121
, MutableAtomicRef (..)
2222
, MutableCollection (..)
23-
, MutableInitialSizedCollection (..)
24-
, MutableIndexing (..)
23+
, MutableAllocatedCollection (..)
24+
, CollIndex
25+
, MutableIndexingWrite (..)
2526
, MutablePushFront (..)
2627
, MutablePushBack (..)
2728
, MutablePopFront (..)
@@ -228,90 +229,85 @@ instance Monoid w => MutableCollection (MutVar s w) where
228229
instance MutableCollection (MV.MVector s a) where
229230
type CollElement (MV.MVector s a) = a
230231
newColl = MV.new 0
231-
{-# INLINE newColl #-}
232232
instance MPV.Prim a => MutableCollection (MPV.MVector s a) where
233233
type CollElement (MPV.MVector s a) = a
234234
newColl = MPV.new 0
235-
{-# INLINE newColl #-}
236235
instance Storable a => MutableCollection (MSV.MVector s a) where
237236
type CollElement (MSV.MVector s a) = a
238237
newColl = MSV.new 0
239-
{-# INLINE newColl #-}
240238
instance MUV.Unbox a => MutableCollection (MUV.MVector s a) where
241239
type CollElement (MUV.MVector s a) = a
242240
newColl = MUV.new 0
243-
{-# INLINE newColl #-}
244241
instance (GHC.Arr.Ix i, Num i) => MutableCollection (GHC.Arr.STArray s i e) where
245242
type CollElement (GHC.Arr.STArray s i e) = e
246243
newColl = primToPrim $ GHC.Arr.newSTArray (0,0) undefined
247-
{-# INLINE newColl #-}
248244
instance Storable a => MutableCollection (Ptr a) where
249245
type CollElement (Ptr a) = a
250246
newColl = primToPrim $ Foreign.mallocArray 0
251-
{-# INLINE newColl #-}
252247

253248
-- | Containers that can be initialized with n elements.
254-
class MutableCollection c => MutableInitialSizedCollection c where
255-
type CollIndex c
249+
type family CollIndex c
250+
251+
class MutableCollection c => MutableAllocatedCollection c where
256252
newCollOfSize :: (PrimMonad m, PrimState m ~ MCState c)
257253
=> CollIndex c
258254
-> m c
259-
instance MutableInitialSizedCollection (MV.MVector s a) where
260-
type CollIndex (MV.MVector s a) = Int
255+
type instance CollIndex (MV.MVector s a) = Int
256+
instance MutableAllocatedCollection (MV.MVector s a) where
261257
newCollOfSize = MV.new
262258
{-# INLINE newCollOfSize #-}
263-
instance MPV.Prim a => MutableInitialSizedCollection (MPV.MVector s a) where
264-
type CollIndex (MPV.MVector s a) = Int
259+
type instance CollIndex (MPV.MVector s a) = Int
260+
instance MPV.Prim a => MutableAllocatedCollection (MPV.MVector s a) where
265261
newCollOfSize = MPV.new
266262
{-# INLINE newCollOfSize #-}
267-
instance Storable a => MutableInitialSizedCollection (MSV.MVector s a) where
268-
type CollIndex (MSV.MVector s a) = Int
263+
type instance CollIndex (MSV.MVector s a) = Int
264+
instance Storable a => MutableAllocatedCollection (MSV.MVector s a) where
269265
newCollOfSize = MSV.new
270266
{-# INLINE newCollOfSize #-}
271-
instance MUV.Unbox a => MutableInitialSizedCollection (MUV.MVector s a) where
272-
type CollIndex (MUV.MVector s a) = Int
267+
type instance CollIndex (MUV.MVector s a) = Int
268+
instance MUV.Unbox a => MutableAllocatedCollection (MUV.MVector s a) where
273269
newCollOfSize = MUV.new
274270
{-# INLINE newCollOfSize #-}
275-
instance (GHC.Arr.Ix i, Num i) => MutableInitialSizedCollection (GHC.Arr.STArray s i e) where
276-
type CollIndex (GHC.Arr.STArray s i e) = i
271+
type instance CollIndex (GHC.Arr.STArray s i e) = i
272+
instance (GHC.Arr.Ix i, Num i) => MutableAllocatedCollection (GHC.Arr.STArray s i e) where
277273
newCollOfSize x = primToPrim $ GHC.Arr.newSTArray (0,x) undefined
278274
{-# INLINE newCollOfSize #-}
279-
instance Storable a => MutableInitialSizedCollection (Ptr a) where
280-
type CollIndex (Ptr a) = Int
275+
type instance CollIndex (Ptr a) = Int
276+
instance Storable a => MutableAllocatedCollection (Ptr a) where
281277
newCollOfSize = primToPrim . Foreign.mallocArray
282278
{-# INLINE newCollOfSize #-}
283279

284-
class MutableInitialSizedCollection c => MutableIndexing c where
285-
readIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> m (CollElement c)
280+
class MutableAllocatedCollection c => MutableIndexingWrite c where
281+
-- readIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> m (CollElement c)
286282
writeIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> CollElement c -> m ()
287-
instance MutableIndexing (MV.MVector s a) where
288-
readIndex = MV.read
289-
{-# INLINE readIndex #-}
283+
instance MutableIndexingWrite (MV.MVector s a) where
284+
-- readIndex = MV.read
285+
-- {-# INLINE readIndex #-}
290286
writeIndex = MV.write
291287
{-# INLINE writeIndex #-}
292-
instance MPV.Prim a => MutableIndexing (MPV.MVector s a) where
293-
readIndex = MPV.read
294-
{-# INLINE readIndex #-}
288+
instance MPV.Prim a => MutableIndexingWrite (MPV.MVector s a) where
289+
-- readIndex = MPV.read
290+
-- {-# INLINE readIndex #-}
295291
writeIndex = MPV.write
296292
{-# INLINE writeIndex #-}
297-
instance Storable a => MutableIndexing (MSV.MVector s a) where
298-
readIndex = MSV.read
299-
{-# INLINE readIndex #-}
293+
instance Storable a => MutableIndexingWrite (MSV.MVector s a) where
294+
-- readIndex = MSV.read
295+
-- {-# INLINE readIndex #-}
300296
writeIndex = MSV.write
301297
{-# INLINE writeIndex #-}
302-
instance MUV.Unbox a => MutableIndexing (MUV.MVector s a) where
303-
readIndex = MUV.read
304-
{-# INLINE readIndex #-}
298+
instance MUV.Unbox a => MutableIndexingWrite (MUV.MVector s a) where
299+
-- readIndex = MUV.read
300+
-- {-# INLINE readIndex #-}
305301
writeIndex = MUV.write
306302
{-# INLINE writeIndex #-}
307-
instance (GHC.Arr.Ix i, Num i) => MutableIndexing (GHC.Arr.STArray s i e) where
308-
readIndex c i = primToPrim $ GHC.Arr.readSTArray c i
309-
{-# INLINE readIndex #-}
303+
instance (GHC.Arr.Ix i, Num i) => MutableIndexingWrite (GHC.Arr.STArray s i e) where
304+
-- readIndex c i = primToPrim $ GHC.Arr.readSTArray c i
305+
-- {-# INLINE readIndex #-}
310306
writeIndex c i e = primToPrim $ GHC.Arr.writeSTArray c i e
311307
{-# INLINE writeIndex #-}
312-
instance Storable a => MutableIndexing (Ptr a) where
313-
readIndex p i = primToPrim $ Foreign.peekElemOff p i
314-
{-# INLINE readIndex #-}
308+
instance Storable a => MutableIndexingWrite (Ptr a) where
309+
-- readIndex p i = primToPrim $ Foreign.peekElemOff p i
310+
-- {-# INLINE readIndex #-}
315311
writeIndex p i e = primToPrim $ Foreign.pokeElemOff p i e
316312
{-# INLINE writeIndex #-}
317313

0 commit comments

Comments
 (0)
⚡