@@ -3,11 +3,12 @@
33
44module Streamly.Internal.Data.Unboxed
55 ( Unboxed
6+ , Unbox(..)
67 , alignment
78 , peekWith
89 , pokeWith
910 , sizeOf
10− , ArrayContents(..)
11+ , MutableByteArray(..)
1112 , castContents
1213 , touch
1314 , getMutableByteArray#
@@ -20,10 +21,11 @@ module Streamly.Internal.Data.Unboxed
2021
2122#include "ArrayMacros.h"
2223
23−import Data.Complex (Complex((:+)), realPart)
24+import Data.Complex (Complex((:+)))
2425import GHC.Base (IO(..))
2526import GHC.Int (Int32(..), Int64(..))
2627import GHC.Word (Word8(..), Word64(..))
28+import Foreign.Storable (Storable(..))
2729
2830import GHC.Exts
2931
@@ -32,19 +34,19 @@ import GHC.Exts
3234--------------------------------------------------------------------------------
3335
3436-- XXX can use UnliftedNewtypes
35−data ArrayContents a = ArrayContents !(MutableByteArray# RealWorld)
37+data MutableByteArray a = MutableByteArray !(MutableByteArray# RealWorld)
3638
3739{-# INLINE getMutableByteArray# #-}
38−getMutableByteArray# :: ArrayContents a -> MutableByteArray# RealWorld
39−getMutableByteArray# (ArrayContents mbarr) = mbarr
40+getMutableByteArray# :: MutableByteArray a -> MutableByteArray# RealWorld
41+getMutableByteArray# (MutableByteArray mbarr) = mbarr
4042
4143{-# INLINE castContents #-}
42−castContents :: ArrayContents a -> ArrayContents b
43−castContents (ArrayContents mbarr) = ArrayContents mbarr
44+castContents :: MutableByteArray a -> MutableByteArray b
45+castContents (MutableByteArray mbarr) = MutableByteArray mbarr
4446
4547{-# INLINE touch #-}
46−touch :: ArrayContents a -> IO ()
47−touch (ArrayContents contents) =
48+touch :: MutableByteArray a -> IO ()
49+touch (MutableByteArray contents) =
4850 IO $ \s -> case touch# contents s of s' -> (# s', () #)
4951
5052--------------------------------------------------------------------------------
@@ -52,13 +54,13 @@ touch (ArrayContents contents) =
5254--------------------------------------------------------------------------------
5355
5456{-# INLINE newUnpinnedArrayContents #-}
55−newUnpinnedArrayContents :: Int -> IO (ArrayContents a)
57+newUnpinnedArrayContents :: Int -> IO (MutableByteArray a)
5658newUnpinnedArrayContents nbytes | nbytes < 0 =
5759 errorWithoutStackTrace "newUnpinnedArrayContents: size must be >= 0"
5860newUnpinnedArrayContents (I# nbytes) = IO $ \s ->
5961 case newByteArray# nbytes s of
6062 (# s', mbarr# #) ->
61− let c = ArrayContents mbarr#
63+ let c = MutableByteArray mbarr#
6264 in (# s', c #)
6365
6466-------------------------------------------------------------------------------
@@ -66,8 +68,8 @@ newUnpinnedArrayContents (I# nbytes) = IO $ \s ->
6668-------------------------------------------------------------------------------
6769
6870{-# INLINE isPinned #-}
69−isPinned :: ArrayContents a -> Bool
70−isPinned (ArrayContents arr#) =
71+isPinned :: MutableByteArray a -> Bool
72+isPinned (MutableByteArray arr#) =
7173 let pinnedInt = I# (isMutableByteArrayPinned# arr#)
7274 in pinnedInt == 1
7375
@@ -88,24 +90,24 @@ cloneMutableArrayWith# alloc# arr# s# =
8890 s3# -> (# s3#, arr1# #)
8991
9092{-# INLINE pin #-}
91−pin :: ArrayContents a -> IO (ArrayContents a)
92−pin arr@(ArrayContents marr#) =
93+pin :: MutableByteArray a -> IO (MutableByteArray a)
94+pin arr@(MutableByteArray marr#) =
9395 if isPinned arr
9496 then return arr
9597 else IO
9698 $ \s# ->
9799 case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
98− (# s1#, marr1# #) -> (# s1#, ArrayContents marr1# #)
100+ (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #)
99101
100102{-# INLINE unpin #-}
101−unpin :: ArrayContents a -> IO (ArrayContents a)
102−unpin arr@(ArrayContents marr#) =
103+unpin :: MutableByteArray a -> IO (MutableByteArray a)
104+unpin arr@(MutableByteArray marr#) =
103105 if not (isPinned arr)
104106 then return arr
105107 else IO
106108 $ \s# ->
107109 case cloneMutableArrayWith# newByteArray# marr# s# of
108− (# s1#, marr1# #) -> (# s1#, ArrayContents marr1# #)
110+ (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #)
109111
110112--------------------------------------------------------------------------------
111113-- The Unboxed type class
@@ -225,14 +227,16 @@ writeWord8ArrayAsDouble# arr# i# =
225227-- class allows each primitive type to have its own specific efficient
226228-- implementation to read and write the type to memory.
227229--
228−-- The ArrayContents type currently uses a MutableByteArray#. However, we could
229−-- also use a foreign ptr instead. That would just make the implementation a
230−-- bit more complicated. In that case the type class would have to support
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
233−-- errors. However, it should be simple to implement unmanaged/read-only memory
234−-- arrays by allowing a Ptr type in ArrayContents, though it would require all
235−-- instances to support reading from a Ptr.
230+-- This is a typeclass that uses MutableByteArray but could use ForeignPtr or
231+-- any other representation of memory. We could make this a multiparameter type
232+-- class if necessary.
233+--
234+-- If the type class would have to support reading and writing to a Ptr as well,
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
237+-- implement unmanaged/read-only memory arrays by allowing a Ptr type in
238+-- ArrayContents, though it would require all instances to support reading from
239+-- a Ptr.
236240--
237241-- There is a reason for using byte offset instead of element index in read and
238242-- write operations in the type class. If we use element index slicing of the
@@ -245,144 +249,116 @@ writeWord8ArrayAsDouble# arr# i# =
245249-- anymore, see
246250-- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/
247251--
248−-- We try to keep the instances compatible with Storable. But we may have to
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.
252+-- We have to keep the instances compatible with Storable as we depend on it for
253+-- size and alignment. We can possibly write tests for checking compatibility
254+-- with Storable.
252255
253−-- | An 'Unboxed' type supplies operations for reading and writing the type
256+-- | An 'Unbox' type supplies operations for reading and writing the type
254257-- from and to a byte array in memory. The read operation constructs the boxed
255258-- type from an unboxed byte representation in memory. The write operation
256259-- writes the boxed type to an unboxed byte representation in memory.
257260--
258−-- This type class is similar to Storable. While Storable allows writing to a
259−-- Ptr, this type class allows writing to a MutableByteArray#.
260−class Unboxed a where
261− sizeOf :: a -> Int
262− alignment :: a -> Int
263−
264− -- Read an element of type "a" from a MutableByteArray given the byte
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
263+-- peekByteOff and pokeByteOff. While Storable allows writing to a Ptr, this
264+-- type class allows writing to a MutableByteArray#.
265+class Storable a => Unbox a where
266+ -- | Read an element of type "a" from a MutableByteArray given the byte
265267 -- index.
266− readByteArray :: ArrayContents a -> Int -> IO a
267− writeByteArray :: ArrayContents a -> Int -> a -> IO ()
268−
269−#define DERIVE_UNBOXED(_type, _constructor, _sizeOf, _alignment, _readArray, _writeArray) \
270−instance Unboxed _type where { \
271−; {-# INLINE sizeOf #-} \
272−; sizeOf _ = _sizeOf \
273−; {-# INLINE alignment #-} \
274−; alignment _ = _alignment \
275−; {-# INLINE readByteArray #-} \
276−; readByteArray (ArrayContents mbarr) (I# n) = IO $ \s -> \
268+ box :: MutableByteArray a -> Int -> IO a
269+ -- | Write an element of type "a" to a MutableByteArray given the byte
270+ -- index.
271+ unbox :: MutableByteArray a -> Int -> a -> IO ()
272+
273+type Unboxed a = (Unbox a, Storable a)
274+
275+#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray) \
276+instance Unbox _type where { \
277+; {-# INLINE box #-} \
278+; box (MutableByteArray mbarr) (I# n) = IO $ \s -> \
277279 case _readArray mbarr n s of \
278280 { (# s1, i #) -> (# s1, _constructor i #) } \
279−; {-# INLINE writeByteArray #-} \
280−; writeByteArray (ArrayContents mbarr) (I# n) (_constructor val) = \
281+; {-# INLINE unbox #-} \
282+; unbox (MutableByteArray mbarr) (I# n) (_constructor val) = \
281283 IO $ \s -> (# _writeArray mbarr n val s, () #) \
282284}
283285
284286DERIVE_UNBOXED( Char
285287 , C#
286− , SIZEOF_HSCHAR
287− , ALIGNMENT_HSCHAR
288288 , readWord8ArrayAsWideChar#
289289 , writeWord8ArrayAsWideChar#)
290290
291291DERIVE_UNBOXED( Int32
292292 , I32#
293− , SIZEOF_INT32
294− , ALIGNMENT_INT32
295293 , readWord8ArrayAsInt32#
296294 , writeWord8ArrayAsInt32#)
297295
298296DERIVE_UNBOXED( Int
299297 , I#
300− , SIZEOF_HSINT
301− , ALIGNMENT_HSINT
302298 , readWord8ArrayAsInt#
303299 , writeWord8ArrayAsInt#)
304300
305301DERIVE_UNBOXED( Int64
306302 , I64#
307− , SIZEOF_INT64
308− , ALIGNMENT_INT64
309303 , readWord8ArrayAsInt64#
310304 , writeWord8ArrayAsInt64#)
311305
312306DERIVE_UNBOXED( Word
313307 , W#
314− , SIZEOF_HSWORD
315− , ALIGNMENT_HSWORD
316308 , readWord8ArrayAsWord#
317309 , writeWord8ArrayAsWord#)
318310
319311DERIVE_UNBOXED( Word8
320312 , W8#
321− , SIZEOF_WORD8
322− , ALIGNMENT_WORD8
323313 , readWord8Array#
324314 , writeWord8Array#)
325315
326316DERIVE_UNBOXED( Word64
327317 , W64#
328− , SIZEOF_WORD64
329− , ALIGNMENT_WORD64
330318 , readWord8ArrayAsWord64#
331319 , writeWord8ArrayAsWord64#)
332320
333321DERIVE_UNBOXED( Double
334322 , D#
335− , SIZEOF_DOUBLE
336− , ALIGNMENT_DOUBLE
337323 , readWord8ArrayAsDouble#
338324 , writeWord8ArrayAsDouble#)
339325
340−instance Unboxed Bool where
341− {-# INLINE sizeOf #-}
342− sizeOf _ = sizeOf (undefined :: Word8)
343−
344− {-# INLINE alignment #-}
345− alignment _ = alignment (undefined :: Word8)
326+instance Unbox Bool where
346327
347− {-# INLINE readByteArray #-}
348− readByteArray arr i = do
349− res <- readByteArray (castContents arr) i
350− return $ res /= (0 :: Word8)
328+ {-# INLINE box #-}
329+ box arr i = do
330+ res <- box (castContents arr) i
331+ return $ res /= (0 :: Int32)
351332
352− {-# INLINE writeByteArray #-}
353− writeByteArray arr i a =
333+ {-# INLINE unbox #-}
334+ unbox arr i a =
354335 if a
355− then writeByteArray (castContents arr) i (1 :: Word8)
356− else writeByteArray (castContents arr) i (0 :: Word8)
357−
358−instance forall a. Unboxed a => Unboxed (Complex a) where
359− {-# INLINE sizeOf #-}
360− sizeOf a = 2 * sizeOf (realPart a)
336+ then unbox (castContents arr) i (1 :: Int32)
337+ else unbox (castContents arr) i (0 :: Int32)
361338
362− {-# INLINE alignment #-}
363− alignment a = alignment (realPart a)
339+instance forall a. Unboxed a => Unbox (Complex a) where
364340
365− {-# INLINE readByteArray #-}
366− readByteArray arr i = do
367− let contents = castContents arr :: ArrayContents a
368− real <- readByteArray contents i
369− img <- readByteArray contents (i + SIZE_OF(a))
341+ {-# INLINE box #-}
342+ box arr i = do
343+ let contents = castContents arr :: MutableByteArray a
344+ real <- box contents i
345+ img <- box contents (i + SIZE_OF(a))
370346 return $ real :+ img
371347
372− {-# INLINE writeByteArray #-}
373− writeByteArray arr i (real :+ img) = do
374− let contents = castContents arr :: ArrayContents a
375− writeByteArray contents i real
376− writeByteArray contents (i + SIZE_OF(a)) img
348+ {-# INLINE unbox #-}
349+ unbox arr i (real :+ img) = do
350+ let contents = castContents arr :: MutableByteArray a
351+ unbox contents i real
352+ unbox contents (i + SIZE_OF(a)) img
377353
378354--------------------------------------------------------------------------------
379355-- Functions
380356--------------------------------------------------------------------------------
381357
382358{-# INLINE peekWith #-}
383−peekWith :: Unboxed a => ArrayContents a -> Int -> IO a
384−peekWith = readByteArray
359+peekWith :: Unboxed a => MutableByteArray a -> Int -> IO a
360+peekWith = box
385361
386362{-# INLINE pokeWith #-}
387−pokeWith :: Unboxed a => ArrayContents a -> Int -> a -> IO ()
388−pokeWith = writeByteArray
363+pokeWith :: Unboxed a => MutableByteArray a -> Int -> a -> IO ()
364+pokeWith = unbox