@@ -3,11 +3,12 @@
4module Streamly.Internal.Data.Unboxed
4module Streamly.Internal.Data.Unboxed
6 , alignment
7 , alignment
10− , ArrayContents(..)
11+ , MutableByteArray(..)
11 , castContents
12 , castContents
13 , getMutableByteArray#
14 , getMutableByteArray#
@@ -20,10 +21,11 @@ module Streamly.Internal.Data.Unboxed
21#include "ArrayMacros.h"
22#include "ArrayMacros.h"
23−import Data.Complex (Complex((:+)), realPart)
24+import Data.Complex (Complex((:+)))
24import GHC.Base (IO(..))
25import GHC.Base (IO(..))
25import GHC.Int (Int32(..), Int64(..))
26import GHC.Int (Int32(..), Int64(..))
26import GHC.Word (Word8(..), Word64(..))
27import GHC.Word (Word8(..), Word64(..))
28+import Foreign.Storable (Storable(..))
28import GHC.Exts
30import GHC.Exts
@@ -32,19 +34,19 @@ import GHC.Exts
32--------------------------------------------------------------------------------
34--------------------------------------------------------------------------------
34-- XXX can use UnliftedNewtypes
36-- XXX can use UnliftedNewtypes
35−data ArrayContents a = ArrayContents !(MutableByteArray# RealWorld)
37+data MutableByteArray a = MutableByteArray !(MutableByteArray# RealWorld)
37{-# INLINE getMutableByteArray# #-}
39{-# INLINE getMutableByteArray# #-}
38−getMutableByteArray# :: ArrayContents a -> MutableByteArray# RealWorld
40+getMutableByteArray# :: MutableByteArray a -> MutableByteArray# RealWorld
39−getMutableByteArray# (ArrayContents mbarr) = mbarr
41+getMutableByteArray# (MutableByteArray mbarr) = mbarr
41{-# INLINE castContents #-}
43{-# INLINE castContents #-}
42−castContents :: ArrayContents a -> ArrayContents b
44+castContents :: MutableByteArray a -> MutableByteArray b
43−castContents (ArrayContents mbarr) = ArrayContents mbarr
45+castContents (MutableByteArray mbarr) = MutableByteArray mbarr
45{-# INLINE touch #-}
47{-# INLINE touch #-}
46−touch :: ArrayContents a -> IO ()
48+touch :: MutableByteArray a -> IO ()
47−touch (ArrayContents contents) =
49+touch (MutableByteArray contents) =
48 IO $ \s -> case touch# contents s of s' -> (# s', () #)
50 IO $ \s -> case touch# contents s of s' -> (# s', () #)
50--------------------------------------------------------------------------------
52--------------------------------------------------------------------------------
@@ -52,13 +54,13 @@ touch (ArrayContents contents) =
52--------------------------------------------------------------------------------
54--------------------------------------------------------------------------------
54{-# INLINE newUnpinnedArrayContents #-}
56{-# INLINE newUnpinnedArrayContents #-}
55−newUnpinnedArrayContents :: Int -> IO (ArrayContents a)
57+newUnpinnedArrayContents :: Int -> IO (MutableByteArray a)
56newUnpinnedArrayContents nbytes | nbytes < 0 =
58newUnpinnedArrayContents nbytes | nbytes < 0 =
57 errorWithoutStackTrace "newUnpinnedArrayContents: size must be >= 0"
59 errorWithoutStackTrace "newUnpinnedArrayContents: size must be >= 0"
58newUnpinnedArrayContents (I# nbytes) = IO $ \s ->
60newUnpinnedArrayContents (I# nbytes) = IO $ \s ->
59 case newByteArray# nbytes s of
61 case newByteArray# nbytes s of
60 (# s', mbarr# #) ->
62 (# s', mbarr# #) ->
61− let c = ArrayContents mbarr#
63+ let c = MutableByteArray mbarr#
62 in (# s', c #)
64 in (# s', c #)
64-------------------------------------------------------------------------------
66-------------------------------------------------------------------------------
@@ -66,8 +68,8 @@ newUnpinnedArrayContents (I# nbytes) = IO $ \s ->
66-------------------------------------------------------------------------------
68-------------------------------------------------------------------------------
68{-# INLINE isPinned #-}
70{-# INLINE isPinned #-}
69−isPinned :: ArrayContents a -> Bool
71+isPinned :: MutableByteArray a -> Bool
70−isPinned (ArrayContents arr#) =
72+isPinned (MutableByteArray arr#) =
71 let pinnedInt = I# (isMutableByteArrayPinned# arr#)
73 let pinnedInt = I# (isMutableByteArrayPinned# arr#)
72 in pinnedInt == 1
74 in pinnedInt == 1
@@ -88,24 +90,24 @@ cloneMutableArrayWith# alloc# arr# s# =
88 s3# -> (# s3#, arr1# #)
90 s3# -> (# s3#, arr1# #)
90{-# INLINE pin #-}
92{-# INLINE pin #-}
91−pin :: ArrayContents a -> IO (ArrayContents a)
93+pin :: MutableByteArray a -> IO (MutableByteArray a)
92−pin arr@(ArrayContents marr#) =
94+pin arr@(MutableByteArray marr#) =
93 if isPinned arr
95 if isPinned arr
94 then return arr
96 then return arr
97 case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
99 case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
98− (# s1#, marr1# #) -> (# s1#, ArrayContents marr1# #)
100+ (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #)
100{-# INLINE unpin #-}
102{-# INLINE unpin #-}
101−unpin :: ArrayContents a -> IO (ArrayContents a)
103+unpin :: MutableByteArray a -> IO (MutableByteArray a)
102−unpin arr@(ArrayContents marr#) =
104+unpin arr@(MutableByteArray marr#) =
103 if not (isPinned arr)
105 if not (isPinned arr)
104 then return arr
106 then return arr
107 case cloneMutableArrayWith# newByteArray# marr# s# of
109 case cloneMutableArrayWith# newByteArray# marr# s# of
108− (# s1#, marr1# #) -> (# s1#, ArrayContents marr1# #)
110+ (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #)
110--------------------------------------------------------------------------------
112--------------------------------------------------------------------------------
111-- The Unboxed type class
113-- The Unboxed type class
@@ -225,14 +227,16 @@ writeWord8ArrayAsDouble# arr# i# =
225-- class allows each primitive type to have its own specific efficient
227-- class allows each primitive type to have its own specific efficient
226-- implementation to read and write the type to memory.
228-- implementation to read and write the type to memory.
228−-- The ArrayContents type currently uses a MutableByteArray#. However, we could
230+-- This is a typeclass that uses MutableByteArray but could use ForeignPtr or
229−-- also use a foreign ptr instead. That would just make the implementation a
231+-- any other representation of memory. We could make this a multiparameter type
232+-- class if necessary.
230−-- bit more complicated. In that case the type class would have to support
234+-- If the type class would have to support reading and writing to a Ptr as well,
231−-- reading and writing to a Ptr as well, basically what Storable does. We will
232−-- also need to touch the anchoring ptr at the right points which is prone to
235+-- basically what Storable does. We will also need to touch the anchoring ptr at
236+-- the right points which is prone to errors. However, it should be simple to
233−-- errors. However, it should be simple to implement unmanaged/read-only memory
237+-- implement unmanaged/read-only memory arrays by allowing a Ptr type in
234−-- arrays by allowing a Ptr type in ArrayContents, though it would require all
235−-- instances to support reading from a Ptr.
238+-- ArrayContents, though it would require all instances to support reading from
237-- There is a reason for using byte offset instead of element index in read and
241-- There is a reason for using byte offset instead of element index in read and
238-- write operations in the type class. If we use element index slicing of the
242-- write operations in the type class. If we use element index slicing of the
@@ -245,144 +249,116 @@ writeWord8ArrayAsDouble# arr# i# =
245-- anymore, see
249-- anymore, see
246-- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/
250-- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/
248−-- We try to keep the instances compatible with Storable. But we may have to
252+-- We have to keep the instances compatible with Storable as we depend on it for
249−-- differ, for example a Bool instance can be implemented more efficiently
250−-- using a bit vector. Need to check the performance. We can possibly write
251−-- tests for checking compatibility with Storable.
253+-- size and alignment. We can possibly write tests for checking compatibility
253−-- | An 'Unboxed' type supplies operations for reading and writing the type
256+-- | An 'Unbox' type supplies operations for reading and writing the type
254-- from and to a byte array in memory. The read operation constructs the boxed
257-- from and to a byte array in memory. The read operation constructs the boxed
255-- type from an unboxed byte representation in memory. The write operation
258-- type from an unboxed byte representation in memory. The write operation
256-- writes the boxed type to an unboxed byte representation in memory.
259-- writes the boxed type to an unboxed byte representation in memory.
261+-- This type class dependes on Storable for size and alignment of the type. It
262+-- is similar to Storable in the sense that it has corresponding operations for
258−-- This type class is similar to Storable. While Storable allows writing to a
263+-- peekByteOff and pokeByteOff. While Storable allows writing to a Ptr, this
259−-- Ptr, this type class allows writing to a MutableByteArray#.
264+-- type class allows writing to a MutableByteArray#.
260−class Unboxed a where
265+class Storable a => Unbox a where
262− alignment :: a -> Int
264− -- Read an element of type "a" from a MutableByteArray given the byte
266+ -- | Read an element of type "a" from a MutableByteArray given the byte
265 -- index.
267 -- index.
266− readByteArray :: ArrayContents a -> Int -> IO a
268+ box :: MutableByteArray a -> Int -> IO a
267− writeByteArray :: ArrayContents a -> Int -> a -> IO ()
269+ -- | Write an element of type "a" to a MutableByteArray given the byte
271+ unbox :: MutableByteArray a -> Int -> a -> IO ()
273+type Unboxed a = (Unbox a, Storable a)
269−#define DERIVE_UNBOXED(_type, _constructor, _sizeOf, _alignment, _readArray, _writeArray) \
275+#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray) \
270−instance Unboxed _type where { \
276+instance Unbox _type where { \
271−; {-# INLINE sizeOf #-} \
277+; {-# INLINE box #-} \
272−; sizeOf _ = _sizeOf \
278+; box (MutableByteArray mbarr) (I# n) = IO $ \s -> \
273−; {-# INLINE alignment #-} \
274−; alignment _ = _alignment \
275−; {-# INLINE readByteArray #-} \
276−; readByteArray (ArrayContents mbarr) (I# n) = IO $ \s -> \
277 case _readArray mbarr n s of \
279 case _readArray mbarr n s of \
278 { (# s1, i #) -> (# s1, _constructor i #) } \
280 { (# s1, i #) -> (# s1, _constructor i #) } \
279−; {-# INLINE writeByteArray #-} \
281+; {-# INLINE unbox #-} \
280−; writeByteArray (ArrayContents mbarr) (I# n) (_constructor val) = \
282+; unbox (MutableByteArray mbarr) (I# n) (_constructor val) = \
281 IO $ \s -> (# _writeArray mbarr n val s, () #) \
283 IO $ \s -> (# _writeArray mbarr n val s, () #) \
284DERIVE_UNBOXED( Char
286DERIVE_UNBOXED( Char
288 , readWord8ArrayAsWideChar#
288 , readWord8ArrayAsWideChar#
289 , writeWord8ArrayAsWideChar#)
289 , writeWord8ArrayAsWideChar#)
291DERIVE_UNBOXED( Int32
291DERIVE_UNBOXED( Int32
295 , readWord8ArrayAsInt32#
293 , readWord8ArrayAsInt32#
296 , writeWord8ArrayAsInt32#)
294 , writeWord8ArrayAsInt32#)
298DERIVE_UNBOXED( Int
296DERIVE_UNBOXED( Int
302 , readWord8ArrayAsInt#
298 , readWord8ArrayAsInt#
303 , writeWord8ArrayAsInt#)
299 , writeWord8ArrayAsInt#)
305DERIVE_UNBOXED( Int64
301DERIVE_UNBOXED( Int64
309 , readWord8ArrayAsInt64#
303 , readWord8ArrayAsInt64#
310 , writeWord8ArrayAsInt64#)
304 , writeWord8ArrayAsInt64#)
312DERIVE_UNBOXED( Word
306DERIVE_UNBOXED( Word
316 , readWord8ArrayAsWord#
308 , readWord8ArrayAsWord#
317 , writeWord8ArrayAsWord#)
309 , writeWord8ArrayAsWord#)
319DERIVE_UNBOXED( Word8
311DERIVE_UNBOXED( Word8
323 , readWord8Array#
313 , readWord8Array#
324 , writeWord8Array#)
314 , writeWord8Array#)
326DERIVE_UNBOXED( Word64
316DERIVE_UNBOXED( Word64
330 , readWord8ArrayAsWord64#
318 , readWord8ArrayAsWord64#
331 , writeWord8ArrayAsWord64#)
319 , writeWord8ArrayAsWord64#)
333DERIVE_UNBOXED( Double
321DERIVE_UNBOXED( Double
337 , readWord8ArrayAsDouble#
323 , readWord8ArrayAsDouble#
338 , writeWord8ArrayAsDouble#)
324 , writeWord8ArrayAsDouble#)
340−instance Unboxed Bool where
326+instance Unbox Bool where
341− {-# INLINE sizeOf #-}
342− sizeOf _ = sizeOf (undefined :: Word8)
344− {-# INLINE alignment #-}
345− alignment _ = alignment (undefined :: Word8)
347− {-# INLINE readByteArray #-}
328+ {-# INLINE box #-}
348− readByteArray arr i = do
329+ box arr i = do
349− res <- readByteArray (castContents arr) i
330+ res <- box (castContents arr) i
350− return $ res /= (0 :: Word8)
331+ return $ res /= (0 :: Int32)
352− {-# INLINE writeByteArray #-}
333+ {-# INLINE unbox #-}
353− writeByteArray arr i a =
334+ unbox arr i a =
355− then writeByteArray (castContents arr) i (1 :: Word8)
336+ then unbox (castContents arr) i (1 :: Int32)
356− else writeByteArray (castContents arr) i (0 :: Word8)
337+ else unbox (castContents arr) i (0 :: Int32)
358−instance forall a. Unboxed a => Unboxed (Complex a) where
359− {-# INLINE sizeOf #-}
360− sizeOf a = 2 * sizeOf (realPart a)
362− {-# INLINE alignment #-}
339+instance forall a. Unboxed a => Unbox (Complex a) where
363− alignment a = alignment (realPart a)
365− {-# INLINE readByteArray #-}
341+ {-# INLINE box #-}
366− readByteArray arr i = do
342+ box arr i = do
367− let contents = castContents arr :: ArrayContents a
343+ let contents = castContents arr :: MutableByteArray a
368− real <- readByteArray contents i
344+ real <- box contents i
369− img <- readByteArray contents (i + SIZE_OF(a))
345+ img <- box contents (i + SIZE_OF(a))
370 return $ real :+ img
346 return $ real :+ img
372− {-# INLINE writeByteArray #-}
348+ {-# INLINE unbox #-}
373− writeByteArray arr i (real :+ img) = do
349+ unbox arr i (real :+ img) = do
374− let contents = castContents arr :: ArrayContents a
350+ let contents = castContents arr :: MutableByteArray a
375− writeByteArray contents i real
351+ unbox contents i real
376− writeByteArray contents (i + SIZE_OF(a)) img
352+ unbox contents (i + SIZE_OF(a)) img
378--------------------------------------------------------------------------------
354--------------------------------------------------------------------------------
379-- Functions
355-- Functions
380--------------------------------------------------------------------------------
356--------------------------------------------------------------------------------
382{-# INLINE peekWith #-}
358{-# INLINE peekWith #-}
383−peekWith :: Unboxed a => ArrayContents a -> Int -> IO a
359+peekWith :: Unboxed a => MutableByteArray a -> Int -> IO a
384−peekWith = readByteArray
360+peekWith = box
386{-# INLINE pokeWith #-}
362{-# INLINE pokeWith #-}
387−pokeWith :: Unboxed a => ArrayContents a -> Int -> a -> IO ()
363+pokeWith :: Unboxed a => MutableByteArray a -> Int -> a -> IO ()
388−pokeWith = writeByteArray
364+pokeWith = unbox