@@ -18,8 +18,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
18 -- $arrayNotes
18 -- $arrayNotes
19 Array (..)
19 Array (..)
20 , ArrayContents
20 , ArrayContents
21− , arrayToFptrContents
22− , fptrToArrayContents
23 , nilArrayContents
21 , nilArrayContents
@@ -29,9 +27,10 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
30 -- *** Uninitialized Arrays
28 -- *** Uninitialized Arrays
31 , newArray
29 , newArray
30+ , newPinnedArrayBytes
32 , newArrayAligned
31 , newArrayAligned
33− , newArrayAlignedUnmanaged
34 , newArrayWith
32 , newArrayWith
33+ , newAlignedArrayContents
36 -- *** Initialized Arrays
35 -- *** Initialized Arrays
37 , withNewArrayUnsafe
36 , withNewArrayUnsafe
@@ -43,7 +42,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
43 , writeNUnsafe
42 , writeNUnsafe
45 , writeNAligned
44 , writeNAligned
46− , writeNAlignedUnmanaged
48 , writeWith
46 , writeWith
@@ -52,7 +50,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
52 -- , writeRev
50 -- , writeRev
54 -- ** From containers
52 -- ** From containers
55− , fromForeignPtrUnsafe
56 , fromListN
53 , fromListN
57 , fromList
54 , fromList
58 , fromListRevN
55 , fromListRevN
@@ -98,7 +95,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
98 -- * Eliminating and Reading
95 -- * Eliminating and Reading
100 -- ** To streams
97 -- ** To streams
103 , readRevWith
99 , readRevWith
104 , readRev
100 , readRev
@@ -194,6 +190,8 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
194 , spliceWith
190 , spliceWith
196 , spliceExp
192 , spliceExp
197 -- , putSlice
195 -- , putSlice
198 -- , appendSlice
196 -- , appendSlice
199 -- , appendSliceFrom
197 -- , appendSliceFrom
@@ -214,10 +212,6 @@ where
214#include "ArrayMacros.h"
212#include "ArrayMacros.h"
215#include "MachDeps.h"
213#include "MachDeps.h"
218−#define USE_FOREIGN_PTR
221import Control.Exception (assert)
215import Control.Exception (assert)
222import Control.DeepSeq (NFData(..), NFData1(..))
216import Control.DeepSeq (NFData(..), NFData1(..))
223import Control.Monad (when, void)
217import Control.Monad (when, void)
@@ -228,27 +222,27 @@ import Data.Semigroup (Semigroup(..))
229import Data.Word (Word8)
223import Data.Word (Word8)
230import Foreign.C.Types (CSize(..), CInt(..))
224import Foreign.C.Types (CSize(..), CInt(..))
231−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
232−#ifndef USE_FOREIGN_PTR
233−import Foreign.Marshal.Alloc (mallocBytes)
235−import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)
225+import Foreign.Ptr (plusPtr, minusPtr, nullPtr)
226+import Streamly.Internal.Control.Exception (assertM)
236import Streamly.Internal.Data.Unboxed
227import Streamly.Internal.Data.Unboxed
237− ( Storable, alignment, peek, poke, sizeOf
230+ , alignment
232+ , getMutableByteArray#
239import GHC.Base
238import GHC.Base
240− ( touch#, IO(..), byteArrayContents#
239+ ( IO(..), byteArrayContents#
241 , Int(..), newAlignedPinnedByteArray#
240 , Int(..), newAlignedPinnedByteArray#
241+ , copyMutableByteArray#, compareByteArrays#
243−#ifndef USE_FOREIGN_PTR
244−import GHC.Base (RealWorld, MutableByteArray#)
246import GHC.Base (noinline)
243import GHC.Base (noinline)
247import GHC.Exts (unsafeCoerce#)
244import GHC.Exts (unsafeCoerce#)
248−import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
245+
250−import GHC.ForeignPtr (mallocForeignPtrAlignedBytes)
252import GHC.Ptr (Ptr(..))
246import GHC.Ptr (Ptr(..))
254import Streamly.Internal.Data.Fold.Type (Fold(..))
248import Streamly.Internal.Data.Fold.Type (Fold(..))
@@ -267,9 +261,6 @@ import qualified Streamly.Internal.Data.Producer as Producer
267import qualified Streamly.Internal.Data.Stream.StreamD.Type as D
261import qualified Streamly.Internal.Data.Stream.StreamD.Type as D
268import qualified Streamly.Internal.Data.Stream.StreamK.Type as K
262import qualified Streamly.Internal.Data.Stream.StreamK.Type as K
269import qualified Streamly.Internal.Data.Stream.Type as Stream
263import qualified Streamly.Internal.Data.Stream.Type as Stream
270−#ifdef USE_FOREIGN_PTR
271−import qualified Streamly.Internal.Foreign.Malloc as Malloc
273import qualified Prelude
264import qualified Prelude
275import Prelude hiding
266import Prelude hiding
@@ -315,37 +306,6 @@ memcmp p1 p2 len = do
315 r <- c_memcmp p1 p2 (fromIntegral len)
306 r <- c_memcmp p1 p2 (fromIntegral len)
316 return $ r == 0
307 return $ r == 0
318−-------------------------------------------------------------------------------
320−-------------------------------------------------------------------------------
322−-- We support using ForeignPtrContents or MutableByteArray.
324−#ifdef USE_FOREIGN_PTR
325−newtype ArrayContents = ArrayContents ForeignPtrContents
328−-- XXX can use UnliftedNewtypes
329−data ArrayContents = ArrayContents !(MutableByteArray# RealWorld)
330−#define UNPACKIF {-# UNPACK #-}
334−touch :: ArrayContents -> IO ()
335−touch (ArrayContents contents) =
336− IO $ \s -> case touch# contents s of s' -> (# s', () #)
338−fptrToArrayContents :: ForeignPtrContents -> ArrayContents
339−arrayToFptrContents :: ArrayContents -> ForeignPtrContents
340−#ifdef USE_FOREIGN_PTR
341−fptrToArrayContents = ArrayContents
342−arrayToFptrContents (ArrayContents contents) = contents
344−fptrToArrayContents (PlainPtr mbarr) = ArrayContents mbarr
345−fptrToArrayContents _ = error "Unsupported foreign ptr"
346−arrayToFptrContents (ArrayContents contents) = PlainPtr contents
349-------------------------------------------------------------------------------
309-------------------------------------------------------------------------------
350-- Array Data Type
310-- Array Data Type
351-------------------------------------------------------------------------------
311-------------------------------------------------------------------------------
@@ -380,11 +340,15 @@ data Array a =
380#ifdef DEVBUILD
340#ifdef DEVBUILD
381 Storable a =>
341 Storable a =>
343+ -- The array is a range into arrContents. arrContents may be a superset of
344+ -- the slice represented by the array. All offsets are in bytes.
384− { arrContents :: UNPACKIF !ArrayContents
346+ { arrContents :: {-# UNPACK #-} !(ArrayContents a)
385− , arrStart :: {-# UNPACK #-} !(Ptr a) -- ^ first address
347+ , arrStart :: {-# UNPACK #-} !Int -- ^ index into arrContents
386− , aEnd :: {-# UNPACK #-} !(Ptr a) -- ^ first unused address
348+ , aEnd :: {-# UNPACK #-} !Int -- ^ index into arrContents
387− , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory
349+ -- Represents the first invalid index of
351+ , aBound :: {-# UNPACK #-} !Int -- ^ first invalid index of arrContents.
390-------------------------------------------------------------------------------
354-------------------------------------------------------------------------------
@@ -413,101 +377,37 @@ data Array a =
413-- /Pre-release/
377-- /Pre-release/
414{-# INLINE newArrayWith #-}
378{-# INLINE newArrayWith #-}
415newArrayWith :: forall m a. (MonadIO m, Storable a)
379newArrayWith :: forall m a. (MonadIO m, Storable a)
416− => (Int -> Int -> m (ArrayContents, Ptr a)) -> Int -> Int -> m (Array a)
380+ => (Int -> Int -> m (ArrayContents a)) -> Int -> Int -> m (Array a)
417newArrayWith alloc alignSize count = do
381newArrayWith alloc alignSize count = do
418 let size = max (count * SIZE_OF(a)) 0
382 let size = max (count * SIZE_OF(a)) 0
419− (contents, p) <- alloc size alignSize
383+ contents <- alloc size alignSize
420 return $ Array
384 return $ Array
421 { arrContents = contents
385 { arrContents = contents
422− , arrStart = p
386+ , arrStart = 0
423− , aEnd = p
387+ , aEnd = 0
424− , aBound = p `plusPtr` size
388+ , aBound = size
427−newAlignedArrayContents :: Int -> Int -> IO (ArrayContents, Ptr a)
391+newAlignedArrayContents :: Int -> Int -> IO (ArrayContents a)
429−newAlignedArrayContents size align = do
392+newAlignedArrayContents nbytes _align | nbytes < 0 =
430− (ForeignPtr addr contents) <- mallocForeignPtrAlignedBytes size align
431− return (ArrayContents contents, Ptr addr)
433−newAlignedArrayContents size _align | size < 0 =
434 errorWithoutStackTrace "newAlignedArrayContents: size must be >= 0"
393 errorWithoutStackTrace "newAlignedArrayContents: size must be >= 0"
435−newAlignedArrayContents (I# size) (I# align) = IO $ \s ->
394+newAlignedArrayContents (I# nbytes) (I# align) = IO $ \s ->
436− case newAlignedPinnedByteArray# size align s of
395+ case newAlignedPinnedByteArray# nbytes align s of
437 (# s', mbarr# #) ->
396 (# s', mbarr# #) ->
438− let p = Ptr (byteArrayContents# (unsafeCoerce# mbarr#))
439−#ifdef USE_FOREIGN_PTR
440− c = ArrayContents (PlainPtr mbarr#)
442− c = ArrayContents mbarr#
397+ let c = ArrayContents mbarr#
444− in (# s', (c, p) #)
398+ in (# s', c #)
447{-# NOINLINE nilArrayContents #-}
400{-# NOINLINE nilArrayContents #-}
448−nilArrayContents :: ArrayContents
401+nilArrayContents :: ArrayContents a
449nilArrayContents =
402nilArrayContents =
450− fst $ unsafePerformIO $ newAlignedArrayContents 0 0
403+ unsafePerformIO $ newAlignedArrayContents 0 0
453#ifdef DEVBUILD
406#ifdef DEVBUILD
454 Storable a =>
407 Storable a =>
457−nil = Array nilArrayContents nullPtr nullPtr nullPtr
410+nil = Array nilArrayContents 0 0 0
459−-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts
460−-- at the memory pointed by the @foreignPtr@, @end@ is the first unused
461−-- address, and @bound@ is the first address beyond the allocated memory.
463−-- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an
464−-- integral multiple of the element size. Only PlainPtr type ForeignPtr is
469−{-# INLINE fromForeignPtrUnsafe #-}
470−fromForeignPtrUnsafe ::
474− ForeignPtr a -> Ptr a -> Ptr a -> Array a
475−fromForeignPtrUnsafe (ForeignPtr start _) _ _
476− | Ptr start == nullPtr = nil
477−fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound =
478− assert (unsafeForeignPtrToPtr fp <= end && end <= bound)
479− (Array (fptrToArrayContents contents) (Ptr start) end bound)
481−-- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned
482−-- memory. The memory will never be freed by GHC. This could be useful in
483−-- allocate-once global data structures. Use carefully as incorrect use can
484−-- lead to memory leak.
487−{-# INLINE newArrayAlignedUnmanaged #-}
488−newArrayAlignedUnmanaged :: forall m a. (MonadIO m, Storable a) =>
489− Int -> Int -> m (Array a)
490−#ifdef USE_FOREIGN_PTR
491−newArrayAlignedUnmanaged = do
492− newArrayWith mallocForeignPtrAlignedUnmanagedBytes
496− mallocForeignPtrAlignedUnmanagedBytes size align = do
497− ForeignPtr addr contents <-
498− liftIO $ Malloc.mallocForeignPtrAlignedUnmanagedBytes size align
499− return (ArrayContents contents, Ptr addr)
501−newArrayAlignedUnmanaged _align count = do
502− let size = max (count * SIZE_OF(a)) 0
503− p <- liftIO $ mallocBytes size
505− { arrContents = nilArrayContents
508− , aBound = p `plusPtr` size
512-- | Like 'newArrayWith' but using an allocator that aligns the memory to the
412-- | Like 'newArrayWith' but using an allocator that aligns the memory to the
513-- alignment dictated by the 'Storable' instance of the type.
413-- alignment dictated by the 'Storable' instance of the type.
@@ -528,6 +428,23 @@ newArrayAligned = newArrayWith (\s a -> liftIO $ newAlignedArrayContents s a)
528newArray :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)
428newArray :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)
529newArray = newArrayAligned (alignment (undefined :: a))
429newArray = newArrayAligned (alignment (undefined :: a))
431+-- | Allocates a pinned empty array that can hold 'count' items. The memory of
432+-- the array is uninitialized and the allocation is aligned as per the
433+-- 'Storable' instance of the type.
436+{-# INLINE newPinnedArrayBytes #-}
437+newPinnedArrayBytes :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)
438+newPinnedArrayBytes bytes = do
440+ liftIO $ newAlignedArrayContents bytes (alignment (undefined :: a))
442+ { arrContents = contents
531-- | Allocate an Array of the given size and run an IO action passing the array
448-- | Allocate an Array of the given size and run an IO action passing the array
532-- start pointer.
449-- start pointer.
@@ -551,25 +468,15 @@ withNewArrayUnsafe count f = do
551{-# INLINE putIndexUnsafe #-}
468{-# INLINE putIndexUnsafe #-}
552putIndexUnsafe :: forall m a. (MonadIO m, Storable a)
469putIndexUnsafe :: forall m a. (MonadIO m, Storable a)
553 => Int -> a -> Array a -> m ()
470 => Int -> a -> Array a -> m ()
554−putIndexUnsafe i x arr@(Array{..}) =
471+putIndexUnsafe i x (Array {..}) = do
555− asPtrUnsafe arr $ \ptr -> do
472+ let index = INDEX_OF(arrStart, i, a)
556− let elemPtr = PTR_INDEX(ptr,i,a)
557− assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ())
473+ assert (i >= 0 && INDEX_VALID(index, aEnd, a)) (return ())
558− liftIO $ poke elemPtr x
474+ liftIO $ pokeWith arrContents index x
560invalidIndex :: String -> Int -> a
476invalidIndex :: String -> Int -> a
561invalidIndex label i =
477invalidIndex label i =
562 error $ label ++ ": invalid array index " ++ show i
478 error $ label ++ ": invalid array index " ++ show i
564−{-# INLINE putIndexPtr #-}
565−putIndexPtr :: forall m a. (MonadIO m, Storable a) =>
566− Ptr a -> Ptr a -> Int -> a -> m ()
567−putIndexPtr start end i x = do
568− let elemPtr = PTR_INDEX(start,i,a)
569− if i >= 0 && PTR_VALID(elemPtr,end,a)
570− then liftIO $ poke elemPtr x
571− else invalidIndex "putIndexPtr" i
573-- | /O(1)/ Write the given element at the given index in the array.
480-- | /O(1)/ Write the given element at the given index in the array.
574-- Performs in-place mutation of the array.
481-- Performs in-place mutation of the array.
@@ -579,10 +486,12 @@ putIndexPtr start end i x = do
580-- /Pre-release/
487-- /Pre-release/
581{-# INLINE putIndex #-}
488{-# INLINE putIndex #-}
582−putIndex :: (MonadIO m, Storable a) => Int -> a -> Array a -> m ()
489+putIndex :: forall m a. (MonadIO m, Storable a) => Int -> a -> Array a -> m ()
583−putIndex i x arr =
490+putIndex i x Array{..} = do
584− asPtrUnsafe arr
491+ let index = INDEX_OF(arrStart,i,a)
585− $ \p -> putIndexPtr p (aEnd arr) i x
492+ if i >= 0 && INDEX_VALID(index,aEnd,a)
493+ then liftIO $ pokeWith arrContents index x
494+ else invalidIndex "putIndex" i
587-- | Write an input stream of (index, value) pairs to an array. Throws an
496-- | Write an input stream of (index, value) pairs to an array. Throws an
588-- error if any index is out of bounds.
497-- error if any index is out of bounds.
@@ -591,51 +500,40 @@ putIndex i x arr =
591{-# INLINE putIndices #-}
500{-# INLINE putIndices #-}
592putIndices :: forall m a. (MonadIO m, Storable a)
501putIndices :: forall m a. (MonadIO m, Storable a)
593 => Array a -> Fold m (Int, a) ()
502 => Array a -> Fold m (Int, a) ()
594−putIndices Array{..} = FL.rmapM extract $ FL.foldlM' step initial
503+putIndices arr = FL.foldlM' step (return ())
600− step () (i, x) = liftIO (putIndexPtr arrStart aEnd i x)
507+ step () (i, x) = liftIO (putIndex i x arr)
602− extract () = liftIO $ touch arrContents
604-- | Modify a given index of an array using a modifier function.
509-- | Modify a given index of an array using a modifier function.
606-- /Pre-release/
511-- /Pre-release/
607modifyIndexUnsafe :: forall m a b. (MonadIO m, Storable a) =>
512modifyIndexUnsafe :: forall m a b. (MonadIO m, Storable a) =>
608 Int -> (a -> (a, b)) -> Array a -> m b
513 Int -> (a -> (a, b)) -> Array a -> m b
609−modifyIndexUnsafe i f arr@(Array{..}) = do
514+modifyIndexUnsafe i f (Array{..}) = liftIO $ do
610− liftIO $ asPtrUnsafe arr $ \ptr -> do
515+ let index = INDEX_OF(arrStart,i,a)
611− let elemPtr = PTR_INDEX(ptr,i,a)
612− assert (i >= 0 && PTR_NEXT(elemPtr,a) <= aEnd) (return ())
516+ assert (i >= 0 && INDEX_NEXT(index,a) <= aEnd) (return ())
613− r <- peek elemPtr
517+ r <- peekWith arrContents index
614 let (x, res) = f r
518 let (x, res) = f r
615− poke elemPtr x
519+ pokeWith arrContents index x
616 return res
520 return res
618−{-# INLINE modifyIndexPtr #-}
619−modifyIndexPtr :: forall m a b. (MonadIO m, Storable a) =>
620− Int -> (a -> (a, b)) -> Ptr a -> Ptr a -> m b
621−modifyIndexPtr i f start end = liftIO $ do
622− let elemPtr = PTR_INDEX(start,i,a)
623− if i >= 0 && PTR_VALID(elemPtr,end,a)
629− else invalidIndex "modifyIndex" i
631-- | Modify a given index of an array using a modifier function.
522-- | Modify a given index of an array using a modifier function.
633-- /Pre-release/
524-- /Pre-release/
634modifyIndex :: forall m a b. (MonadIO m, Storable a) =>
525modifyIndex :: forall m a b. (MonadIO m, Storable a) =>
635 Int -> (a -> (a, b)) -> Array a -> m b
526 Int -> (a -> (a, b)) -> Array a -> m b
636−modifyIndex i f arr@(Array{..}) = do
527+modifyIndex i f Array{..} = do
637− liftIO $ asPtrUnsafe arr $ \ptr -> do
528+ let index = INDEX_OF(arrStart,i,a)
638− modifyIndexPtr i f ptr aEnd
529+ if i >= 0 && INDEX_VALID(index,aEnd,a)
531+ r <- peekWith arrContents index
533+ pokeWith arrContents index x
535+ else invalidIndex "modifyIndex" i
640-- | Modify the array indices generated by the supplied stream.
538-- | Modify the array indices generated by the supplied stream.
@@ -643,41 +541,39 @@ modifyIndex i f arr@(Array{..}) = do
643{-# INLINE modifyIndices #-}
541{-# INLINE modifyIndices #-}
644modifyIndices :: forall m a . (MonadIO m, Storable a)
542modifyIndices :: forall m a . (MonadIO m, Storable a)
645 => (Int -> a -> a) -> Array a -> Fold m Int ()
543 => (Int -> a -> a) -> Array a -> Fold m Int ()
646−modifyIndices f Array{..} = Fold step initial extract
544+modifyIndices f arr = FL.foldlM' step initial
650− initial = return $ FL.Partial ()
548+ initial = return ()
652 step () i =
550 step () i =
653 let f1 x = (f i x, ())
551 let f1 x = (f i x, ())
654− in FL.Partial <$> liftIO (modifyIndexPtr i f1 arrStart aEnd)
552+ in modifyIndex i f1 arr
656− extract () = liftIO $ touch arrContents
658-- | Modify each element of an array using the supplied modifier function.
554-- | Modify each element of an array using the supplied modifier function.
660-- /Pre-release/
556-- /Pre-release/
661modify :: forall m a. (MonadIO m, Storable a)
557modify :: forall m a. (MonadIO m, Storable a)
662 => (a -> a) -> Array a -> m ()
558 => (a -> a) -> Array a -> m ()
663−modify f arr@Array{..} = liftIO $
559+modify f Array{..} = liftIO $
664− asPtrUnsafe arr go
560+ go arrStart
669− when (PTR_VALID(ptr,aEnd,a)) $ do
565+ when (INDEX_VALID(i,aEnd,a)) $ do
670− r <- peek ptr
566+ r <- peekWith arrContents i
671− poke ptr (f r)
567+ pokeWith arrContents i (f r)
672− go (PTR_NEXT(ptr,a))
568+ go (INDEX_NEXT(i,a))
674−{-# INLINE swapPtrs #-}
570+{-# INLINE swapArrayByteIndices #-}
675−swapPtrs :: Storable a => Ptr a -> Ptr a -> IO ()
571+swapArrayByteIndices :: Storable a => ArrayContents a -> Int -> Int -> IO ()
676−swapPtrs ptr1 ptr2 = do
572+swapArrayByteIndices arrContents i1 i2 = do
677− r1 <- peek ptr1
573+ r1 <- peekWith arrContents i1
678− r2 <- peek ptr2
574+ r2 <- peekWith arrContents i2
679− poke ptr1 r2
575+ pokeWith arrContents i1 r2
680− poke ptr2 r1
576+ pokeWith arrContents i2 r1
682-- | Swap the elements at two indices without validating the indices.
578-- | Swap the elements at two indices without validating the indices.
@@ -687,11 +583,10 @@ swapPtrs ptr1 ptr2 = do
687{-# INLINE unsafeSwapIndices #-}
583{-# INLINE unsafeSwapIndices #-}
688unsafeSwapIndices :: forall m a. (MonadIO m, Storable a)
584unsafeSwapIndices :: forall m a. (MonadIO m, Storable a)
689 => Int -> Int -> Array a -> m ()
585 => Int -> Int -> Array a -> m ()
690−unsafeSwapIndices i1 i2 arr = liftIO $ do
586+unsafeSwapIndices i1 i2 Array{..} = liftIO $ do
691− asPtrUnsafe arr $ \ptr -> do
587+ let t1 = INDEX_OF(arrStart,i1,a)
692− let ptr1 = PTR_INDEX(ptr,i1,a)
588+ t2 = INDEX_OF(arrStart,i2,a)
693− ptr2 = PTR_INDEX(ptr,i2,a)
589+ swapArrayByteIndices arrContents t1 t2
694− swapPtrs ptr1 (ptr2 :: Ptr a)
696-- | Swap the elements at two indices.
591-- | Swap the elements at two indices.
@@ -699,13 +594,13 @@ unsafeSwapIndices i1 i2 arr = liftIO $ do
699swapIndices :: forall m a. (MonadIO m, Storable a)
594swapIndices :: forall m a. (MonadIO m, Storable a)
700 => Int -> Int -> Array a -> m ()
595 => Int -> Int -> Array a -> m ()
701swapIndices i1 i2 Array{..} = liftIO $ do
596swapIndices i1 i2 Array{..} = liftIO $ do
702− let ptr1 = PTR_INDEX(arrStart,i1,a)
597+ let t1 = INDEX_OF(arrStart,i1,a)
703− ptr2 = PTR_INDEX(arrStart,i2,a)
598+ t2 = INDEX_OF(arrStart,i2,a)
704− when (i1 < 0 || PTR_INVALID(ptr1,aEnd,a))
599+ when (i1 < 0 || INDEX_INVALID(t1,aEnd,a))
705 $ invalidIndex "swapIndices" i1
600 $ invalidIndex "swapIndices" i1
706− when (i2 < 0 || PTR_INVALID(ptr2,aEnd,a))
601+ when (i2 < 0 || INDEX_INVALID(t2,aEnd,a))
707 $ invalidIndex "swapIndices" i2
602 $ invalidIndex "swapIndices" i2
708− swapPtrs ptr1 (ptr2 :: Ptr a)
603+ swapArrayByteIndices arrContents t1 t2
710-------------------------------------------------------------------------------
605-------------------------------------------------------------------------------
711-- Rounding
606-- Rounding
@@ -797,31 +692,38 @@ roundDownTo elemSize size = size - (size `mod` elemSize)
797-- XXX See if resizing can be implemented by reading the old array as a stream
692-- XXX See if resizing can be implemented by reading the old array as a stream
798-- and then using writeN to the new array.
693-- and then using writeN to the new array.
695+-- NOTE: we are passing elemSize explicitly to avoid a Storable constraint.
696+-- Since this is not inlined Storable consrraint leads to dictionary passing
697+-- which complicates some inspection tests.
800{-# NOINLINE reallocAligned #-}
699{-# NOINLINE reallocAligned #-}
801reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a)
700reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a)
802−reallocAligned elemSize alignSize newCapacity Array{..} = do
701+reallocAligned elemSize alignSize newCapacityInBytes Array{..} = do
803− assert (aEnd <= aBound) (return ())
702+ assertM (aEnd <= aBound)
805 -- Allocate new array
704 -- Allocate new array
806− let newCapMax = roundUpLargeArray newCapacity
705+ let newCapMaxInBytes = roundUpLargeArray newCapacityInBytes
807− (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
706+ contents <- newAlignedArrayContents newCapMaxInBytes alignSize
707+ let !(ArrayContents mbarrFrom#) = arrContents
708+ !(ArrayContents mbarrTo#) = contents
809 -- Copy old data
710 -- Copy old data
810 let oldStart = arrStart
711 let oldStart = arrStart
712+ !(I# oldStartInBytes#) = oldStart
811− oldSize = aEnd `minusPtr` oldStart
713+ oldSizeInBytes = aEnd - oldStart
812− newCap = roundDownTo elemSize newCapMax
714+ newCapInBytes = roundDownTo elemSize newCapMaxInBytes
813− newLen = min oldSize newCap
715+ !newLenInBytes@(I# newLenInBytes#) = min oldSizeInBytes newCapInBytes
814− assert (oldSize `mod` elemSize == 0) (return ())
716+ assert (oldSizeInBytes `mod` elemSize == 0) (return ())
815− assert (newLen >= 0) (return ())
717+ assert (newLenInBytes >= 0) (return ())
816− assert (newLen `mod` elemSize == 0) (return ())
718+ assert (newLenInBytes `mod` elemSize == 0) (return ())
817− memcpy (castPtr pNew) (castPtr oldStart) newLen
719+ IO $ \s# -> (# copyMutableByteArray# mbarrFrom# oldStartInBytes#
818− touch arrContents
720+ mbarrTo# 0# newLenInBytes# s#, () #)
820 return $ Array
722 return $ Array
821− { arrStart = pNew
723+ { arrStart = 0
822 , arrContents = contents
724 , arrContents = contents
823− , aEnd = pNew `plusPtr` newLen
725+ , aEnd = newLenInBytes
824− , aBound = pNew `plusPtr` newCap
726+ , aBound = newCapInBytes
827-- | @realloc newCapacity array@ reallocates the array to the specified
729-- | @realloc newCapacity array@ reallocates the array to the specified
@@ -834,10 +736,10 @@ reallocAligned elemSize alignSize newCapacity Array{..} = do
835{-# INLINABLE realloc #-}
737{-# INLINABLE realloc #-}
836realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
738realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
837−realloc n arr =
739+realloc bytes arr =
838− liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
740+ liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) bytes arr
840−-- | @reallocWith label capSizer minIncrement array@. The label is used
742+-- | @reallocWith label capSizer minIncrBytes array@. The label is used
841-- in error messages and the capSizer is used to determine the capacity of the
743-- in error messages and the capSizer is used to determine the capacity of the
842-- new array in bytes given the current byte length of the array.
744-- new array in bytes given the current byte length of the array.
843reallocWith :: forall m a. (MonadIO m , Storable a) =>
745reallocWith :: forall m a. (MonadIO m , Storable a) =>
@@ -846,22 +748,24 @@ reallocWith :: forall m a. (MonadIO m , Storable a) =>
847 -> Array a
749 -> Array a
848 -> m (Array a)
750 -> m (Array a)
849−reallocWith label capSizer minIncr arr = do
751+reallocWith label capSizer minIncrBytes arr = do
850− let oldSize = aEnd arr `minusPtr` arrStart arr
752+ let oldSizeBytes = aEnd arr - arrStart arr
851− newCap = capSizer oldSize
753+ newCapBytes = capSizer oldSizeBytes
852− newSize = oldSize + minIncr
754+ newSizeBytes = oldSizeBytes + minIncrBytes
853− safeCap = max newCap newSize
755+ safeCapBytes = max newCapBytes newSizeBytes
854− assert (newCap >= newSize || error (badSize newSize)) (return ())
756+ assertM (safeCapBytes >= newSizeBytes || error (badSize newSizeBytes))
855− realloc safeCap arr
758+ realloc safeCapBytes arr
859− badSize newSize = concat
762+ badSize newSize =
861− , ": new array size is less than required size "
765+ , ": new array size (in bytes) is less than required size "
862− , show newSize
766+ , show newSize
863− , ". Please check the sizing function passed."
767+ , ". Please check the sizing function passed."
866-- | @resize newCapacity array@ changes the total capacity of the array so that
770-- | @resize newCapacity array@ changes the total capacity of the array so that
867-- it is enough to hold the specified number of elements. Nothing is done if
771-- it is enough to hold the specified number of elements. Nothing is done if
@@ -874,27 +778,27 @@ reallocWith label capSizer minIncr arr = do
874{-# INLINE resize #-}
778{-# INLINE resize #-}
875resize :: forall m a. (MonadIO m, Storable a) =>
779resize :: forall m a. (MonadIO m, Storable a) =>
876 Int -> Array a -> m (Array a)
780 Int -> Array a -> m (Array a)
877−resize n arr@Array{..} = do
781+resize nElems arr@Array{..} = do
878− let req = SIZE_OF(a) * n
782+ let req = SIZE_OF(a) * nElems
879− len = aEnd `minusPtr` arrStart
783+ len = aEnd - arrStart
880 if req < len
784 if req < len
881 then return arr
785 then return arr
882 else realloc req arr
786 else realloc req arr
884−-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
788+-- | Like 'resize' but if the byte capacity is more than 'largeObjectThreshold'
885−-- it is rounded up to the closest power of 2.
789+-- then it is rounded up to the closest power of 2.
887-- /Pre-release/
791-- /Pre-release/
888{-# INLINE resizeExp #-}
792{-# INLINE resizeExp #-}
889resizeExp :: forall m a. (MonadIO m, Storable a) =>
793resizeExp :: forall m a. (MonadIO m, Storable a) =>
890 Int -> Array a -> m (Array a)
794 Int -> Array a -> m (Array a)
891−resizeExp n arr@Array{..} = do
795+resizeExp nElems arr@Array{..} = do
892− let req = roundUpLargeArray (SIZE_OF(a) * n)
796+ let req = roundUpLargeArray (SIZE_OF(a) * nElems)
894 if req > largeObjectThreshold
798 if req > largeObjectThreshold
895 then roundUpToPower2 req
799 then roundUpToPower2 req
897− len = aEnd `minusPtr` arrStart
801+ len = aEnd - arrStart
898 if req1 < len
802 if req1 < len
899 then return arr
803 then return arr
900 else realloc req1 arr
804 else realloc req1 arr
@@ -912,10 +816,10 @@ rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a)
912rightSize arr@Array{..} = do
816rightSize arr@Array{..} = do
913 assert (aEnd <= aBound) (return ())
817 assert (aEnd <= aBound) (return ())
914 let start = arrStart
818 let start = arrStart
915− len = aEnd `minusPtr` start
819+ len = aEnd - start
916− capacity = aBound `minusPtr` start
820+ capacity = aBound - start
917 target = roundUpLargeArray len
821 target = roundUpLargeArray len
918− waste = aBound `minusPtr` aEnd
822+ waste = aBound - aEnd
919 assert (target >= len) (return ())
823 assert (target >= len) (return ())
920 assert (len `mod` SIZE_OF(a) == 0) (return ())
824 assert (len `mod` SIZE_OF(a) == 0) (return ())
921 -- We trade off some wastage (25%) to avoid reallocations and copying.
825 -- We trade off some wastage (25%) to avoid reallocations and copying.
@@ -940,11 +844,10 @@ rightSize arr@Array{..} = do
941-- /Internal/
845-- /Internal/
942{-# INLINE snocNewEnd #-}
846{-# INLINE snocNewEnd #-}
943−snocNewEnd :: (MonadIO m, Storable a) => Ptr a -> Array a -> a -> m (Array a)
847+snocNewEnd :: (MonadIO m, Storable a) => Int -> Array a -> a -> m (Array a)
944snocNewEnd newEnd arr@Array{..} x = liftIO $ do
848snocNewEnd newEnd arr@Array{..} x = liftIO $ do
945 assert (newEnd <= aBound) (return ())
849 assert (newEnd <= aBound) (return ())
946− poke aEnd x
850+ pokeWith arrContents aEnd x
948 return $ arr {aEnd = newEnd}
851 return $ arr {aEnd = newEnd}
950-- | Really really unsafe, appends the element into the first array, may
853-- | Really really unsafe, appends the element into the first array, may
@@ -955,7 +858,7 @@ snocNewEnd newEnd arr@Array{..} x = liftIO $ do
955{-# INLINE snocUnsafe #-}
858{-# INLINE snocUnsafe #-}
956snocUnsafe :: forall m a. (MonadIO m, Storable a) =>
859snocUnsafe :: forall m a. (MonadIO m, Storable a) =>
957 Array a -> a -> m (Array a)
860 Array a -> a -> m (Array a)
958−snocUnsafe arr@Array{..} = snocNewEnd (PTR_NEXT(aEnd,a)) arr
861+snocUnsafe arr@Array{..} = snocNewEnd (INDEX_NEXT(aEnd,a)) arr
960-- | Like 'snoc' but does not reallocate when pre-allocated array capacity
863-- | Like 'snoc' but does not reallocate when pre-allocated array capacity
961-- becomes full.
864-- becomes full.
@@ -965,7 +868,7 @@ snocUnsafe arr@Array{..} = snocNewEnd (PTR_NEXT(aEnd,a)) arr
965snocMay :: forall m a. (MonadIO m, Storable a) =>
868snocMay :: forall m a. (MonadIO m, Storable a) =>
966 Array a -> a -> m (Maybe (Array a))
869 Array a -> a -> m (Maybe (Array a))
967snocMay arr@Array{..} x = liftIO $ do
870snocMay arr@Array{..} x = liftIO $ do
968− let newEnd = PTR_NEXT(aEnd,a)
871+ let newEnd = INDEX_NEXT(aEnd,a)
969 if newEnd <= aBound
872 if newEnd <= aBound
970 then Just <$> snocNewEnd newEnd arr x
873 then Just <$> snocNewEnd newEnd arr x
971 else return Nothing
874 else return Nothing
@@ -1001,7 +904,7 @@ snocWith :: forall m a. (MonadIO m, Storable a) =>
1002 -> m (Array a)
905 -> m (Array a)
1003snocWith allocSize arr x = liftIO $ do
906snocWith allocSize arr x = liftIO $ do
1004− let newEnd = PTR_NEXT(aEnd arr,a)
907+ let newEnd = INDEX_NEXT(aEnd arr,a)
1005 if newEnd <= aBound arr
908 if newEnd <= aBound arr
1006 then snocNewEnd newEnd arr x
909 then snocNewEnd newEnd arr x
1007 else snocWithRealloc allocSize arr x
910 else snocWithRealloc allocSize arr x
@@ -1049,42 +952,27 @@ snoc = snocWith f
1049-- Random reads
952-- Random reads
1050-------------------------------------------------------------------------------
953-------------------------------------------------------------------------------
955+-- XXX Can this be deduplicated with array/foreign
1052-- | Return the element at the specified index without checking the bounds.
957-- | Return the element at the specified index without checking the bounds.
1054-- Unsafe because it does not check the bounds of the array.
959-- Unsafe because it does not check the bounds of the array.
1055{-# INLINE_NORMAL getIndexUnsafe #-}
960{-# INLINE_NORMAL getIndexUnsafe #-}
1056getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
961getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
1057−getIndexUnsafe i arr@(Array {..}) =
962+getIndexUnsafe i (Array {..}) = do
1058− asPtrUnsafe arr $ \ptr -> do
963+ let index = INDEX_OF(arrStart,i,a)
1059− let elemPtr = PTR_INDEX(ptr,i,a)
1060− assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ())
964+ assert (i >= 0 && INDEX_VALID(index,aEnd,a)) (return ())
1061− liftIO $ peek elemPtr
965+ liftIO $ peekWith arrContents index
1063−{-# INLINE getIndexPtr #-}
1064−getIndexPtr :: forall m a. (MonadIO m, Storable a) =>
1065− Ptr a -> Ptr a -> Int -> m a
1066−getIndexPtr start end i = do
1067− let elemPtr = PTR_INDEX(start,i,a)
1068− if i >= 0 && PTR_VALID(elemPtr,end,a)
1069− then liftIO $ peek elemPtr
1070− else invalidIndex "getIndexPtr" i
1072-- | /O(1)/ Lookup the element at the given index. Index starts from 0.
967-- | /O(1)/ Lookup the element at the given index. Index starts from 0.
1074{-# INLINE getIndex #-}
969{-# INLINE getIndex #-}
1075−getIndex :: (MonadIO m, Storable a) => Int -> Array a -> m a
970+getIndex :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
1076−getIndex i arr =
971+getIndex i Array{..} = do
1077− asPtrUnsafe arr
972+ let index = INDEX_OF(arrStart,i,a)
1078− $ \p -> getIndexPtr p (aEnd arr) i
973+ if i >= 0 && INDEX_VALID(index,aEnd,a)
1079−
974+ then liftIO $ peekWith arrContents index
1080−{-# INLINE getIndexPtrRev #-}
1081−getIndexPtrRev :: forall m a. (MonadIO m, Storable a) =>
1082− Ptr a -> Ptr a -> Int -> m a
1083−getIndexPtrRev start end i = do
1084− let elemPtr = PTR_RINDEX(end,i,a)
1085− if i >= 0 && elemPtr >= start
1086− then liftIO $ peek elemPtr
1087− else invalidIndex "getIndexPtrRev" i
975+ else invalidIndex "getIndex" i
1089-- | /O(1)/ Lookup the element at the given index from the end of the array.
977-- | /O(1)/ Lookup the element at the given index from the end of the array.
1090-- Index starts from 0.
978-- Index starts from 0.
@@ -1092,10 +980,12 @@ getIndexPtrRev start end i = do
1092-- Slightly faster than computing the forward index and using getIndex.
980-- Slightly faster than computing the forward index and using getIndex.
1094{-# INLINE getIndexRev #-}
982{-# INLINE getIndexRev #-}
1095−getIndexRev :: (MonadIO m, Storable a) => Int -> Array a -> m a
983+getIndexRev :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
1096−getIndexRev i arr =
984+getIndexRev i Array{..} = do
1097− asPtrUnsafe arr
985+ let index = RINDEX_OF(aEnd,i,a)
1098− $ \p -> getIndexPtrRev p (aEnd arr) i
986+ if i >= 0 && index >= arrStart
987+ then liftIO $ peekWith arrContents index
988+ else invalidIndex "getIndexRev" i
1100data GetIndicesState contents start end st =
990data GetIndicesState contents start end st =
1101 GetIndicesState contents start end st
991 GetIndicesState contents start end st
@@ -1112,20 +1002,18 @@ getIndicesD liftio (D.Stream stepi sti) = Unfold step inject
1115− inject (Array contents start (Ptr end) _) =
1005+ inject (Array contents start end _) =
1116− return $ GetIndicesState contents start (Ptr end) sti
1006+ return $ GetIndicesState contents start end sti
1118 {-# INLINE_LATE step #-}
1008 {-# INLINE_LATE step #-}
1119 step (GetIndicesState contents start end st) = do
1009 step (GetIndicesState contents start end st) = do
1120 r <- stepi defState st
1010 r <- stepi defState st
1121 case r of
1011 case r of
1122 D.Yield i s -> do
1012 D.Yield i s -> do
1123− x <- liftio $ getIndexPtr start end i
1013+ x <- liftio $ getIndex i (Array contents start end undefined)
1124 return $ D.Yield x (GetIndicesState contents start end s)
1014 return $ D.Yield x (GetIndicesState contents start end s)
1125 D.Skip s -> return $ D.Skip (GetIndicesState contents start end s)
1015 D.Skip s -> return $ D.Skip (GetIndicesState contents start end s)
1127− liftio $ touch contents
1128− return D.Stop
1016+ D.Stop -> return D.Stop
1130{-# INLINE getIndices #-}
1018{-# INLINE getIndices #-}
1131getIndices :: (MonadIO m, Storable a) => Stream m Int -> Unfold m (Array a) a
1019getIndices :: (MonadIO m, Storable a) => Stream m Int -> Unfold m (Array a) a
@@ -1151,8 +1039,8 @@ getSliceUnsafe :: forall a. Storable a
1151 -> Array a
1039 -> Array a
1152 -> Array a
1040 -> Array a
1153getSliceUnsafe index len (Array contents start e _) =
1041getSliceUnsafe index len (Array contents start e _) =
1154− let fp1 = PTR_INDEX(start,index,a)
1042+ let fp1 = INDEX_OF(start,index,a)
1155− end = fp1 `plusPtr` (len * SIZE_OF(a))
1043+ end = fp1 + (len * SIZE_OF(a))
1156 in assert
1044 in assert
1157 (index >= 0 && len >= 0 && end <= e)
1045 (index >= 0 && len >= 0 && end <= e)
1158 -- Note: In a slice we always use bound = end so that the slice
1046 -- Note: In a slice we always use bound = end so that the slice
@@ -1170,8 +1058,8 @@ getSlice :: forall a. Storable a =>
1170 -> Array a
1058 -> Array a
1171 -> Array a
1059 -> Array a
1172getSlice index len (Array contents start e _) =
1060getSlice index len (Array contents start e _) =
1173− let fp1 = PTR_INDEX(start,index,a)
1061+ let fp1 = INDEX_OF(start,index,a)
1174− end = fp1 `plusPtr` (len * SIZE_OF(a))
1062+ end = fp1 + (len * SIZE_OF(a))
1175 in if index >= 0 && len >= 0 && end <= e
1063 in if index >= 0 && len >= 0 && end <= e
1176 -- Note: In a slice we always use bound = end so that the slice user
1064 -- Note: In a slice we always use bound = end so that the slice user
1177 -- cannot overwrite elements beyond the end of the slice.
1065 -- cannot overwrite elements beyond the end of the slice.
@@ -1196,15 +1084,15 @@ getSlice index len (Array contents start e _) =
1196reverse :: forall m a. (MonadIO m, Storable a) => Array a -> m ()
1084reverse :: forall m a. (MonadIO m, Storable a) => Array a -> m ()
1197reverse Array{..} = liftIO $ do
1085reverse Array{..} = liftIO $ do
1198 let l = arrStart
1086 let l = arrStart
1199− h = PTR_PREV(aEnd,a)
1087+ h = INDEX_PREV(aEnd,a)
1200 in swap l h
1088 in swap l h
1204 swap l h = do
1092 swap l h = do
1205 when (l < h) $ do
1093 when (l < h) $ do
1206− swapPtrs l h
1094+ swapArrayByteIndices arrContents l h
1207− swap (PTR_NEXT(l,a)) (PTR_PREV(h,a))
1095+ swap (INDEX_NEXT(l,a)) (INDEX_PREV(h,a))
1209-- | Generate the next permutation of the sequence, returns False if this is
1097-- | Generate the next permutation of the sequence, returns False if this is
1210-- the last permutation.
1098-- the last permutation.
@@ -1226,7 +1114,7 @@ partitionBy f arr@Array{..} = liftIO $ do
1226 if arrStart >= aEnd
1114 if arrStart >= aEnd
1227 then return (arr, arr)
1115 then return (arr, arr)
1229− ptr <- go arrStart (PTR_PREV(aEnd,a))
1117+ ptr <- go arrStart (INDEX_PREV(aEnd,a))
1230 let pl = Array arrContents arrStart ptr ptr
1118 let pl = Array arrContents arrStart ptr ptr
1231 pr = Array arrContents ptr aEnd aEnd
1119 pr = Array arrContents ptr aEnd aEnd
1232 return (pl, pr)
1120 return (pl, pr)
@@ -1235,11 +1123,11 @@ partitionBy f arr@Array{..} = liftIO $ do
1236 -- Invariant low < high on entry, and on return as well
1124 -- Invariant low < high on entry, and on return as well
1237 moveHigh low high = do
1125 moveHigh low high = do
1238− h <- peek high
1126+ h <- peekWith arrContents high
1241 -- Correctly classified, continue the loop
1129 -- Correctly classified, continue the loop
1242− let high1 = PTR_PREV(high,a)
1130+ let high1 = INDEX_PREV(high,a)
1243 in if low == high1
1131 in if low == high1
1244 then return Nothing
1132 then return Nothing
1245 else moveHigh low high1
1133 else moveHigh low high1
@@ -1255,7 +1143,7 @@ partitionBy f arr@Array{..} = liftIO $ do
1255 -- low <= high
1143 -- low <= high
1256 -- Both low and high are valid locations within the array
1144 -- Both low and high are valid locations within the array
1257 go low high = do
1145 go low high = do
1258− l <- peek low
1146+ l <- peekWith arrContents low
1261 -- low is wrongly classified
1149 -- low is wrongly classified
@@ -1266,17 +1154,17 @@ partitionBy f arr@Array{..} = liftIO $ do
1266 case r of
1154 case r of
1267 Nothing -> return low
1155 Nothing -> return low
1268 Just (high1, h) -> do -- low < high1
1156 Just (high1, h) -> do -- low < high1
1269− poke low h
1157+ pokeWith arrContents low h
1270− poke high1 l
1158+ pokeWith arrContents high1 l
1271− let low1 = PTR_NEXT(low,a)
1159+ let low1 = INDEX_NEXT(low,a)
1272− high2 = PTR_PREV(high1,a)
1160+ high2 = INDEX_PREV(high1,a)
1273 if low1 <= high2
1161 if low1 <= high2
1274 then go low1 high2
1162 then go low1 high2
1275 else return low1 -- low1 > high2
1163 else return low1 -- low1 > high2
1278 -- low is correctly classified
1166 -- low is correctly classified
1279− let low1 = PTR_NEXT(low,a)
1167+ let low1 = INDEX_NEXT(low,a)
1280 if low == high
1168 if low == high
1281 then return low1
1169 then return low1
1282 else go low1 high
1170 else go low1 high
@@ -1329,12 +1217,12 @@ mergeBy = undefined
1329{-# INLINE byteLength #-}
1217{-# INLINE byteLength #-}
1330byteLength :: Array a -> Int
1218byteLength :: Array a -> Int
1331byteLength Array{..} =
1219byteLength Array{..} =
1332− let len = aEnd `minusPtr` arrStart
1220+ let len = aEnd - arrStart
1333 in assert (len >= 0) len
1221 in assert (len >= 0) len
1335-- Note: try to avoid the use of length in performance sensitive internal
1223-- Note: try to avoid the use of length in performance sensitive internal
1336-- routines as it involves a costly 'div' operation. Instead use the end ptr
1224-- routines as it involves a costly 'div' operation. Instead use the end ptr
1337−-- int he array to check the bounds etc.
1225+-- in the array to check the bounds etc.
1339-- | /O(1)/ Get the length of the array i.e. the number of elements in the
1227-- | /O(1)/ Get the length of the array i.e. the number of elements in the
1340-- array.
1228-- array.
@@ -1357,7 +1245,7 @@ length arr =
1357{-# INLINE byteCapacity #-}
1245{-# INLINE byteCapacity #-}
1358byteCapacity :: Array a -> Int
1246byteCapacity :: Array a -> Int
1359byteCapacity Array{..} =
1247byteCapacity Array{..} =
1360− let len = aBound `minusPtr` arrStart
1248+ let len = aBound - arrStart
1361 in assert (len >= 0) len
1249 in assert (len >= 0) len
1363-- | The remaining capacity in the array for appending more elements without
1251-- | The remaining capacity in the array for appending more elements without
@@ -1367,7 +1255,7 @@ byteCapacity Array{..} =
1367{-# INLINE bytesFree #-}
1255{-# INLINE bytesFree #-}
1368bytesFree :: Array a -> Int
1256bytesFree :: Array a -> Int
1369bytesFree Array{..} =
1257bytesFree Array{..} =
1370− let n = aBound `minusPtr` aEnd
1258+ let n = aBound - aEnd
1371 in assert (n >= 0) n
1259 in assert (n >= 0) n
1373-------------------------------------------------------------------------------
1261-------------------------------------------------------------------------------
@@ -1413,8 +1301,8 @@ arraysOf n (D.Stream step state) =
1413 r <- step (adaptState gst) st
1301 r <- step (adaptState gst) st
1414 case r of
1302 case r of
1415 D.Yield x s -> do
1303 D.Yield x s -> do
1416− liftIO $ poke end x >> touch contents
1304+ liftIO $ pokeWith contents end x
1417− let end1 = PTR_NEXT(end,a)
1305+ let end1 = INDEX_NEXT(end,a)
1418 return $
1306 return $
1419 if end1 >= bound
1307 if end1 >= bound
1420 then D.Skip
1308 then D.Skip
@@ -1447,7 +1335,7 @@ arrayStreamKFromStreamD =
1448data FlattenState s contents a =
1336data FlattenState s contents a =
1449 OuterLoop s
1337 OuterLoop s
1450− | InnerLoop s contents !(Ptr a) !(Ptr a)
1338+ | InnerLoop s contents !Int !Int
1452-- | Use the "read" unfold instead.
1340-- | Use the "read" unfold instead.
@@ -1475,11 +1363,8 @@ flattenArrays (D.Stream step state) = D.Stream step' (OuterLoop state)
1475 return $ D.Skip $ OuterLoop st
1363 return $ D.Skip $ OuterLoop st
1477 step' _ (InnerLoop st contents p end) = do
1365 step' _ (InnerLoop st contents p end) = do
1480− touch contents
1366+ x <- liftIO $ peekWith contents p
1482− return $ D.Yield x (InnerLoop st contents (PTR_NEXT(p,a)) end)
1367+ return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end)
1484-- | Use the "readRev" unfold instead.
1369-- | Use the "readRev" unfold instead.
@@ -1499,7 +1384,7 @@ flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state)
1499 r <- step (adaptState gst) st
1384 r <- step (adaptState gst) st
1500 return $ case r of
1385 return $ case r of
1501 D.Yield Array{..} s ->
1386 D.Yield Array{..} s ->
1502− let p = PTR_PREV(aEnd,a)
1387+ let p = INDEX_PREV(aEnd,a)
1503 in D.Skip (InnerLoop s arrContents p arrStart)
1388 in D.Skip (InnerLoop s arrContents p arrStart)
1504 D.Skip s -> D.Skip (OuterLoop s)
1389 D.Skip s -> D.Skip (OuterLoop s)
1505 D.Stop -> D.Stop
1390 D.Stop -> D.Stop
@@ -1509,47 +1394,50 @@ flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state)
1510 step' _ (InnerLoop st contents p start) = do
1395 step' _ (InnerLoop st contents p start) = do
1511 x <- liftIO $ do
1396 x <- liftIO $ do
1513− touch contents
1397+ r <- peekWith contents p
1514 return r
1398 return r
1515− let cur = PTR_PREV(p,a)
1399+ let cur = INDEX_PREV(p,a)
1516 return $ D.Yield x (InnerLoop st contents cur start)
1400 return $ D.Yield x (InnerLoop st contents cur start)
1518-------------------------------------------------------------------------------
1402-------------------------------------------------------------------------------
1519-- Unfolds
1403-- Unfolds
1520-------------------------------------------------------------------------------
1404-------------------------------------------------------------------------------
1522−data ReadUState a = ReadUState
1406+data ArrayUnsafe a = ArrayUnsafe
1523− UNPACKIF !ArrayContents -- contents
1407+ {-# UNPACK #-} !(ArrayContents a) -- contents
1524− !(Ptr a) -- end address
1408+ {-# UNPACK #-} !Int -- index 1
1525− !(Ptr a) -- current address
1409+ {-# UNPACK #-} !Int -- index 2
1411+toArrayUnsafe :: Array a -> ArrayUnsafe a
1412+toArrayUnsafe (Array contents start end _) = ArrayUnsafe contents start end
1527−toReadUState :: Array a -> ReadUState a
1414+fromArrayUnsafe ::
1528−toReadUState (Array contents start end _) = ReadUState contents end start
1415+#ifdef DEVBUILD
1418+ ArrayUnsafe a -> Array a
1419+fromArrayUnsafe (ArrayUnsafe contents start end) =
1420+ Array contents start end end
1530{-# INLINE_NORMAL producerWith #-}
1422{-# INLINE_NORMAL producerWith #-}
1531producerWith ::
1423producerWith ::
1532 forall m a. (Monad m, Storable a)
1424 forall m a. (Monad m, Storable a)
1533 => (forall b. IO b -> m b) -> Producer m (Array a) a
1425 => (forall b. IO b -> m b) -> Producer m (Array a) a
1534−producerWith liftio = Producer step (return . toReadUState) extract
1426+producerWith liftio = Producer step (return . toArrayUnsafe) extract
1537 {-# INLINE_LATE step #-}
1429 {-# INLINE_LATE step #-}
1538− step (ReadUState contents end cur)
1430+ step (ArrayUnsafe _ cur end)
1539− | assert (cur <= end) (cur == end) = liftio $ do
1431+ | assert (cur <= end) (cur == end) = return D.Stop
1540− -- We bind it strictly here as we don't want this to be optimized
1541− -- out in a purely lazy monad like Identity.
1542− !_ <- touch contents
1544− step (ReadUState contents end cur) = do
1432+ step (ArrayUnsafe contents cur end) = do
1545 -- When we use a purely lazy Monad like Identity, we need to force a
1433 -- When we use a purely lazy Monad like Identity, we need to force a
1546 -- few actions for correctness and execution order sanity. We want
1434 -- few actions for correctness and execution order sanity. We want
1547 -- the peek to occur right here and not lazily at some later point
1435 -- the peek to occur right here and not lazily at some later point
1548 -- because we want the peek to be ordered with respect to the touch.
1436 -- because we want the peek to be ordered with respect to the touch.
1549− !x <- liftio $ peek cur
1437+ !x <- liftio $ peekWith contents cur
1550− return $ D.Yield x (ReadUState contents end (PTR_NEXT(cur,a)))
1438+ return $ D.Yield x (ArrayUnsafe contents (INDEX_NEXT(cur,a)) end)
1552− extract (ReadUState contents end cur) = return $ Array contents cur end end
1440+ extract = return . fromArrayUnsafe
1554-- | Resumable unfold of an array.
1442-- | Resumable unfold of an array.
@@ -1572,16 +1460,14 @@ readRevWith liftio = Unfold step inject
1574 inject (Array contents start end _) =
1462 inject (Array contents start end _) =
1575− let p = PTR_PREV(end,a)
1463+ let p = INDEX_PREV(end,a)
1576− in return $ ReadUState contents start p
1464+ in return $ ArrayUnsafe contents start p
1578 {-# INLINE_LATE step #-}
1466 {-# INLINE_LATE step #-}
1579− step (ReadUState contents start p) | p < start = liftio $ do
1580− !_ <- touch contents
1581− return D.Stop
1467+ step (ArrayUnsafe _ start p) | p < start = return D.Stop
1582− step (ReadUState contents start p) = do
1468+ step (ArrayUnsafe contents start p) = do
1583− !x <- liftio $ peek p
1469+ !x <- liftio $ peekWith contents p
1584− return $ D.Yield x (ReadUState contents start (PTR_PREV(p,a)))
1470+ return $ D.Yield x (ArrayUnsafe contents start (INDEX_PREV(p,a)))
1586-- | Unfold an array into a stream in reverse order.
1472-- | Unfold an array into a stream in reverse order.
@@ -1612,8 +1498,7 @@ toListFB c n Array{..} = go arrStart
1612 -- evaluated/written to before we peek at them.
1498 -- evaluated/written to before we peek at them.
1614 let !x = unsafeInlineIO $ do
1500 let !x = unsafeInlineIO $ do
1616− touch arrContents
1501+ r <- peekWith arrContents p
1617 return r
1502 return r
1618 in c x (go (PTR_NEXT(p,a)))
1503 in c x (go (PTR_NEXT(p,a)))
@@ -1630,9 +1515,8 @@ toList Array{..} = liftIO $ go arrStart
1631 go p | assert (p <= aEnd) (p == aEnd) = return []
1516 go p | assert (p <= aEnd) (p == aEnd) = return []
1632 go p = do
1517 go p = do
1634− touch arrContents
1518+ x <- peekWith arrContents p
1635− (:) x <$> go (PTR_NEXT(p,a))
1519+ (:) x <$> go (INDEX_NEXT(p,a))
1637{-# INLINE_NORMAL toStreamDWith #-}
1521{-# INLINE_NORMAL toStreamDWith #-}
1638toStreamDWith ::
1522toStreamDWith ::
@@ -1645,9 +1529,8 @@ toStreamDWith liftio Array{..} = D.Stream step arrStart
1645 {-# INLINE_LATE step #-}
1529 {-# INLINE_LATE step #-}
1646 step _ p | assert (p <= aEnd) (p == aEnd) = return D.Stop
1530 step _ p | assert (p <= aEnd) (p == aEnd) = return D.Stop
1647 step _ p = liftio $ do
1531 step _ p = liftio $ do
1649− touch arrContents
1532+ r <- peekWith arrContents p
1650− return $ D.Yield r (PTR_NEXT(p,a))
1533+ return $ D.Yield r (INDEX_NEXT(p,a))
1652-- | Use the 'read' unfold instead.
1535-- | Use the 'read' unfold instead.
@@ -1669,10 +1552,9 @@ toStreamKWith liftio Array{..} = go arrStart
1669 go p | assert (p <= aEnd) (p == aEnd) = K.nil
1552 go p | assert (p <= aEnd) (p == aEnd) = K.nil
1670 | otherwise =
1553 | otherwise =
1671 let elemM = do
1554 let elemM = do
1673− touch arrContents
1555+ r <- peekWith arrContents p
1674 return r
1556 return r
1675− in liftio elemM `K.consM` go (PTR_NEXT(p,a))
1557+ in liftio elemM `K.consM` go (INDEX_NEXT(p,a))
1677{-# INLINE toStreamK #-}
1559{-# INLINE toStreamK #-}
1678toStreamK :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a
1560toStreamK :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a
@@ -1683,7 +1565,7 @@ toStreamDRevWith ::
1683 forall m a. (Monad m, Storable a)
1565 forall m a. (Monad m, Storable a)
1684 => (forall b. IO b -> m b) -> Array a -> D.Stream m a
1566 => (forall b. IO b -> m b) -> Array a -> D.Stream m a
1685toStreamDRevWith liftio Array{..} =
1567toStreamDRevWith liftio Array{..} =
1686− let p = PTR_PREV(aEnd,a)
1568+ let p = INDEX_PREV(aEnd,a)
1687 in D.Stream step p
1569 in D.Stream step p
@@ -1691,9 +1573,8 @@ toStreamDRevWith liftio Array{..} =
1691 {-# INLINE_LATE step #-}
1573 {-# INLINE_LATE step #-}
1692 step _ p | p < arrStart = return D.Stop
1574 step _ p | p < arrStart = return D.Stop
1693 step _ p = liftio $ do
1575 step _ p = liftio $ do
1695− touch arrContents
1576+ r <- peekWith arrContents p
1696− return $ D.Yield r (PTR_PREV(p,a))
1577+ return $ D.Yield r (INDEX_PREV(p,a))
1698-- | Use the 'readRev' unfold instead.
1579-- | Use the 'readRev' unfold instead.
@@ -1709,7 +1590,7 @@ toStreamKRevWith ::
1709 forall m a. (Monad m, Storable a)
1590 forall m a. (Monad m, Storable a)
1710 => (forall b. IO b -> m b) -> Array a -> K.Stream m a
1591 => (forall b. IO b -> m b) -> Array a -> K.Stream m a
1711toStreamKRevWith liftio Array {..} =
1592toStreamKRevWith liftio Array {..} =
1712− let p = PTR_PREV(aEnd,a)
1593+ let p = INDEX_PREV(aEnd,a)
@@ -1717,10 +1598,9 @@ toStreamKRevWith liftio Array {..} =
1717 go p | p < arrStart = K.nil
1598 go p | p < arrStart = K.nil
1718 | otherwise =
1599 | otherwise =
1719 let elemM = do
1600 let elemM = do
1721− touch arrContents
1601+ r <- peekWith arrContents p
1722 return r
1602 return r
1723− in liftio elemM `K.consM` go (PTR_PREV(p,a))
1603+ in liftio elemM `K.consM` go (INDEX_PREV(p,a))
1725{-# INLINE toStreamKRev #-}
1605{-# INLINE toStreamKRev #-}
1726toStreamKRev :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a
1606toStreamKRev :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a
@@ -1747,23 +1627,6 @@ foldr f z arr = D.foldr f z $ toStreamD arr
1748-------------------------------------------------------------------------------
1628-------------------------------------------------------------------------------
1750−data ArrayUnsafe a = ArrayUnsafe
1751− UNPACKIF !ArrayContents -- contents
1752− {-# UNPACK #-} !(Ptr a) -- start address
1753− {-# UNPACK #-} !(Ptr a) -- first unused address
1755−toArrayUnsafe :: Array a -> ArrayUnsafe a
1756−toArrayUnsafe (Array contents start end _) =
1757− ArrayUnsafe contents start end
1763− ArrayUnsafe a -> Array a
1764−fromArrayUnsafe (ArrayUnsafe contents start end) =
1765− Array contents start end end
1767-- Note: Arrays may be allocated with a specific alignment at the beginning of
1630-- Note: Arrays may be allocated with a specific alignment at the beginning of
1768-- the array. If you need to maintain that alignment on reallocations then you
1631-- the array. If you need to maintain that alignment on reallocations then you
1769-- can resize the array manually before append, using an aligned resize
1632-- can resize the array manually before append, using an aligned resize
@@ -1771,7 +1634,8 @@ fromArrayUnsafe (ArrayUnsafe contents start end) =
1772-- XXX Keep the bound intact to not lose any free space? Perf impact?
1635-- XXX Keep the bound intact to not lose any free space? Perf impact?
1774−-- | Append up to @n@ input items to the supplied array.
1637+-- | @appendNUnsafe alloc n@ appends up to @n@ input items to the supplied
1776-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory
1640-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory
1777-- corruption or segfault.
1641-- corruption or segfault.
@@ -1792,7 +1656,7 @@ appendNUnsafe action n =
1792 initial = do
1656 initial = do
1793 assert (n >= 0) (return ())
1657 assert (n >= 0) (return ())
1794 arr@(Array _ _ end bound) <- action
1658 arr@(Array _ _ end bound) <- action
1795− let free = bound `minusPtr` end
1659+ let free = bound - end
1796 needed = n * SIZE_OF(a)
1660 needed = n * SIZE_OF(a)
1797 -- XXX We can also reallocate if the array has too much free space,
1661 -- XXX We can also reallocate if the array has too much free space,
1798 -- otherwise we lose that space.
1662 -- otherwise we lose that space.
@@ -1803,8 +1667,8 @@ appendNUnsafe action n =
1803 return $ toArrayUnsafe arr1
1667 return $ toArrayUnsafe arr1
1805 step (ArrayUnsafe contents start end) x = do
1669 step (ArrayUnsafe contents start end) x = do
1806− liftIO $ poke end x >> touch contents
1670+ liftIO $ pokeWith contents end x
1807− return $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1671+ return $ ArrayUnsafe contents start (INDEX_NEXT(end,a))
1809-- | Append @n@ elements to an existing array. Any free space left in the array
1673-- | Append @n@ elements to an existing array. Any free space left in the array
1810-- after appending @n@ elements is lost.
1674-- after appending @n@ elements is lost.
@@ -1858,17 +1722,16 @@ append = appendWith (* 2)
1858{-# INLINE_NORMAL writeNWithUnsafe #-}
1722{-# INLINE_NORMAL writeNWithUnsafe #-}
1859writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1723writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1860 => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1724 => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1861−writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe)
1725+writeNWithUnsafe alloc n = fromArrayUnsafe <$> FL.foldlM' step initial
1865− initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1729+ initial = toArrayUnsafe <$> alloc (max n 0)
1867 step (ArrayUnsafe contents start end) x = do
1731 step (ArrayUnsafe contents start end) x = do
1868− liftIO $ poke end x >> touch contents
1732+ liftIO $ pokeWith contents end x
1871− $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1734+ $ ArrayUnsafe contents start (INDEX_NEXT(end,a))
1873-- | Like 'writeN' but does not check the array bounds when writing. The fold
1736-- | Like 'writeN' but does not check the array bounds when writing. The fold
1874-- driver must not call the step function more than 'n' times otherwise it will
1737-- driver must not call the step function more than 'n' times otherwise it will
@@ -1913,20 +1776,19 @@ writeN = writeNWith newArray
1913{-# INLINE_NORMAL writeRevNWithUnsafe #-}
1776{-# INLINE_NORMAL writeRevNWithUnsafe #-}
1914writeRevNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1777writeRevNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1915 => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1778 => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1916−writeRevNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe)
1779+writeRevNWithUnsafe alloc n = fromArrayUnsafe <$> FL.foldlM' step initial
1920 toArrayUnsafeRev (Array contents _ _ bound) =
1783 toArrayUnsafeRev (Array contents _ _ bound) =
1921 ArrayUnsafe contents bound bound
1784 ArrayUnsafe contents bound bound
1923− initial = FL.Partial . toArrayUnsafeRev <$> alloc (max n 0)
1786+ initial = toArrayUnsafeRev <$> alloc (max n 0)
1925 step (ArrayUnsafe contents start end) x = do
1788 step (ArrayUnsafe contents start end) x = do
1926− let ptr = PTR_PREV(start,a)
1789+ let ptr = INDEX_PREV(start,a)
1927− liftIO $ poke ptr x >> touch contents
1790+ liftIO $ pokeWith contents ptr x
1930 $ ArrayUnsafe contents ptr end
1792 $ ArrayUnsafe contents ptr end
1932-- | Like writeNWith but writes the array in reverse order.
1794-- | Like writeNWith but writes the array in reverse order.
@@ -1957,23 +1819,6 @@ writeNAligned :: forall m a. (MonadIO m, Storable a)
1957 => Int -> Int -> Fold m a (Array a)
1819 => Int -> Int -> Fold m a (Array a)
1958writeNAligned align = writeNWith (newArrayAligned align)
1820writeNAligned align = writeNWith (newArrayAligned align)
1960−-- | @writeNAlignedUnmanaged align n@ folds a maximum of @n@ elements from the
1961−-- input stream to an 'Array' whose starting address is aligned to @align@
1962−-- bytes and is allocated using unmanaged memory (never freed). This could be
1963−-- useful to allocate memory that we need to allocate only once in the lifetime
1966−-- >>> f = Array.newArrayAlignedUnmanaged
1967−-- >>> writeNAlignedUnmanaged a = Array.writeNWith (f a)
1968−-- >>> writeNAlignedUnmanaged a n = Array.appendN (f a n) n
1972−{-# INLINE_NORMAL writeNAlignedUnmanaged #-}
1973−writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)
1974− => Int -> Int -> Fold m a (Array a)
1975−writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align)
1977-- XXX Buffer to a list instead?
1822-- XXX Buffer to a list instead?
1979-- | Buffer a stream into a stream of arrays.
1824-- | Buffer a stream into a stream of arrays.
@@ -2030,15 +1875,15 @@ writeWith elemCount =
2032 insertElem (Array contents start end bound) x = do
1877 insertElem (Array contents start end bound) x = do
2033− liftIO $ poke end x
1878+ liftIO $ pokeWith contents end x
2034− return $ Array contents start (PTR_NEXT(end,a)) bound
1879+ return $ Array contents start (INDEX_NEXT(end,a)) bound
2036 initial = do
1881 initial = do
2037 when (elemCount < 0) $ error "writeWith: elemCount is negative"
1882 when (elemCount < 0) $ error "writeWith: elemCount is negative"
2038 liftIO $ newArrayAligned (alignment (undefined :: a)) elemCount
1883 liftIO $ newArrayAligned (alignment (undefined :: a)) elemCount
2039 step arr@(Array _ start end bound) x
1884 step arr@(Array _ start end bound) x
2040− | PTR_NEXT(end,a) > bound = do
1885+ | INDEX_NEXT(end,a) > bound = do
2041− let oldSize = end `minusPtr` start
1886+ let oldSize = end - start
2042 newSize = max (oldSize * 2) 1
1887 newSize = max (oldSize * 2) 1
@@ -2077,14 +1922,14 @@ fromStreamDN :: forall m a. (MonadIO m, Storable a)
2077-- fromStreamDN n = D.fold (writeN n)
1922-- fromStreamDN n = D.fold (writeN n)
2078fromStreamDN limit str = do
1923fromStreamDN limit str = do
2079 arr <- liftIO $ newArray limit
1924 arr <- liftIO $ newArray limit
2080− end <- D.foldlM' fwrite (return $ aEnd arr) $ D.take limit str
1925+ end <- D.foldlM' (fwrite (arrContents arr)) (return $ aEnd arr) $ D.take limit str
2081 return $ arr {aEnd = end}
1926 return $ arr {aEnd = end}
2085− fwrite ptr x = do
1930+ fwrite arrContents ptr x = do
2086− liftIO $ poke ptr x
1931+ liftIO $ pokeWith arrContents ptr x
2087− return $ PTR_NEXT(ptr,a)
1932+ return $ INDEX_NEXT(ptr,a)
2089-- | Create an 'Array' from the first N elements of a list. The array is
1934-- | Create an 'Array' from the first N elements of a list. The array is
2090-- allocated to size N, if the list terminates before N elements then the
1935-- allocated to size N, if the list terminates before N elements then the
@@ -2156,45 +2001,60 @@ fromListRev xs = fromListRevN (Prelude.length xs) xs
2156-- Combining
2001-- Combining
2157-------------------------------------------------------------------------------
2002-------------------------------------------------------------------------------
2004+-- | Put a sub range of a source array into a subrange of a destination array.
2005+-- This is not safe as it does not check the bounds.
2006+{-# INLINE putSliceUnsafe #-}
2007+putSliceUnsafe :: MonadIO m => Array a -> Int -> Array a -> Int -> Int -> m ()
2008+putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do
2009+ assertM (lenBytes <= aBound dst - dstStartBytes)
2010+ assertM (lenBytes <= aEnd src - srcStartBytes)
2011+ let !(I# srcStartBytes#) = srcStartBytes
2012+ !(I# dstStartBytes#) = dstStartBytes
2013+ !(I# lenBytes#) = lenBytes
2014+ let arrS# = getMutableByteArray# (arrContents src)
2015+ arrD# = getMutableByteArray# (arrContents dst)
2016+ IO $ \s# -> (# copyMutableByteArray#
2017+ arrS# srcStartBytes# arrD# dstStartBytes# lenBytes# s#
2159-- | Copy two arrays into a newly allocated array.
2020-- | Copy two arrays into a newly allocated array.
2160{-# INLINE spliceCopy #-}
2021{-# INLINE spliceCopy #-}
2161−spliceCopy :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)
2022+spliceCopy :: forall m a. (MonadIO m, Storable a) =>
2023+ Array a -> Array a -> m (Array a)
2162−spliceCopy arr1 arr2 = do
2024+spliceCopy arr1 arr2 = liftIO $ do
2163− let src1 = arrStart arr1
2025+ let start1 = arrStart arr1
2164− src2 = arrStart arr2
2026+ start2 = arrStart arr2
2165− len1 = aEnd arr1 `minusPtr` src1
2027+ len1 = aEnd arr1 - start1
2166− len2 = aEnd arr2 `minusPtr` src2
2028+ len2 = aEnd arr2 - start2
2167−
2029+ newArrContents <-
2031+ $ newAlignedArrayContents
2168− arr <- liftIO $ newArray (len1 + len2)
2032+ (len1 + len2)
2169− let dst = arrStart arr
2033+ (alignment (undefined :: a))
2170−
2034+ let len = len1 + len2
2171− -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to
2035+ newArr = Array newArrContents 0 len len
2172− -- ccall?
2036+ putSliceUnsafe arr1 start1 newArr 0 len1
2173− liftIO $ do
2037+ putSliceUnsafe arr2 start2 newArr len1 len2
2174− memcpy (castPtr dst) (castPtr src1) len1
2038+ return newArr
2175− touch (arrContents arr1)
2176− memcpy (castPtr (dst `plusPtr` len1)) (castPtr src2) len2
2177− touch (arrContents arr2)
2178− return arr { aEnd = dst `plusPtr` (len1 + len2) }
2180-- | Really really unsafe, appends the second array into the first array. If
2040-- | Really really unsafe, appends the second array into the first array. If
2181-- the first array does not have enough space it may cause silent data
2041-- the first array does not have enough space it may cause silent data
2182-- corruption or if you are lucky a segfault.
2042-- corruption or if you are lucky a segfault.
2183{-# INLINE spliceUnsafe #-}
2043{-# INLINE spliceUnsafe #-}
2184−spliceUnsafe :: MonadIO m => Array a -> (Array a, Int) -> m (Array a)
2044+spliceUnsafe :: MonadIO m =>
2045+ Array a -> Array a -> m (Array a)
2185−spliceUnsafe dst (src, srcLen) =
2046+spliceUnsafe dst src =
2186 liftIO $ do
2047 liftIO $ do
2187− let psrc = arrStart src
2048+ let startSrc = arrStart src
2049+ srcLen = aEnd src - startSrc
2188− let pdst = aEnd dst
2050+ endDst = aEnd dst
2189− assert (pdst `plusPtr` srcLen <= aBound dst) (return ())
2051+ assertM (endDst + srcLen <= aBound dst)
2190− memcpy (castPtr pdst) (castPtr psrc) srcLen
2052+ putSliceUnsafe src startSrc dst endDst srcLen
2191− touch (arrContents src)
2192− touch (arrContents dst)
2193− return $ dst {aEnd = pdst `plusPtr` srcLen}
2053+ return $ dst {aEnd = endDst + srcLen}
2195-- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no
2055-- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no
2196-- reserved space available in @dst@ it is reallocated to a size determined by
2056-- reserved space available in @dst@ it is reallocated to a size determined by
2197−-- the @sizer dstBytesn srcBytes@ function, where @dstBytes@ is the size of the
2057+-- the @sizer dstBytes srcBytes@ function, where @dstBytes@ is the size of the
2198-- first array and @srcBytes@ is the size of the second array, in bytes.
2058-- first array and @srcBytes@ is the size of the second array, in bytes.
2200-- Note that the returned array may be a mutated version of first array.
2060-- Note that the returned array may be a mutated version of first array.
@@ -2209,21 +2069,21 @@ spliceWith sizer dst@(Array _ start end bound) src = do
2209 in D.fold f (toStreamD src)
2069 in D.fold f (toStreamD src)
2211 assert (end <= bound) (return ())
2071 assert (end <= bound) (return ())
2212− let srcLen = aEnd src `minusPtr` arrStart src
2072+ let srcBytes = aEnd src - arrStart src
2215− if end `plusPtr` srcLen >= bound
2075+ if end + srcBytes >= bound
2217− let oldSize = end `minusPtr` start
2077+ let dstBytes = end - start
2218− newSize = sizer oldSize srcLen
2078+ newSizeInBytes = sizer dstBytes srcBytes
2219− when (newSize < oldSize + srcLen)
2079+ when (newSizeInBytes < dstBytes + srcBytes)
2221 $ "splice: newSize is less than the total size "
2081 $ "splice: newSize is less than the total size "
2222 ++ "of arrays being appended. Please check the "
2082 ++ "of arrays being appended. Please check the "
2223− ++ "newSize function passed."
2083+ ++ "sizer function passed."
2224− liftIO $ realloc newSize dst
2084+ liftIO $ realloc newSizeInBytes dst
2225 else return dst
2085 else return dst
2226− spliceUnsafe dst1 (src, srcLen)
2086+ spliceUnsafe dst1 src
2228-- | The first array is mutated to append the second array. If there is no
2088-- | The first array is mutated to append the second array. If there is no
2229-- reserved space available in the first array a new allocation of exact
2089-- reserved space available in the first array a new allocation of exact
@@ -2260,9 +2120,12 @@ spliceExp = spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2))
2260{-# INLINE breakOn #-}
2120{-# INLINE breakOn #-}
2261breakOn :: MonadIO m
2121breakOn :: MonadIO m
2262 => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))
2122 => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))
2263−breakOn sep arr@Array{..} = liftIO $ do
2123+breakOn sep arr@Array{..} = asPtrUnsafe arr $ \p -> liftIO $ do
2264− let p = arrStart
2124+ -- XXX Instead of using asPtrUnsafe (pinning memory) we can pass unlifted
2125+ -- Addr# to memchr and it should be safe (from ghc 8.4).
2126+ -- XXX We do not need memchr here, we can use a Haskell equivalent.
2265− loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)
2127+ loc <- c_memchr p sep (fromIntegral $ byteLength arr)
2128+ let sepIndex = loc `minusPtr` p
2266 return $
2129 return $
2267 if loc == nullPtr
2130 if loc == nullPtr
2268 then (arr, Nothing)
2131 then (arr, Nothing)
@@ -2270,12 +2133,12 @@ breakOn sep arr@Array{..} = liftIO $ do
2271 { arrContents = arrContents
2134 { arrContents = arrContents
2272 , arrStart = arrStart
2135 , arrStart = arrStart
2273− , aEnd = loc
2136+ , aEnd = arrStart + sepIndex -- exclude the separator
2274− , aBound = loc
2137+ , aBound = arrStart + sepIndex
2276 , Just $ Array
2139 , Just $ Array
2277 { arrContents = arrContents
2140 { arrContents = arrContents
2278− , arrStart = arrStart `plusPtr` (loc `minusPtr` p + 1)
2141+ , arrStart = arrStart + (sepIndex + 1)
2279 , aEnd = aEnd
2142 , aEnd = aEnd
2280 , aBound = aBound
2143 , aBound = aBound
@@ -2294,7 +2157,7 @@ splitAt i arr@Array{..} =
2294 then error $ "sliceAt: specified array index " ++ show i
2157 then error $ "sliceAt: specified array index " ++ show i
2295 ++ " is beyond the maximum index " ++ show maxIndex
2158 ++ " is beyond the maximum index " ++ show maxIndex
2296 else let off = i * SIZE_OF(a)
2159 else let off = i * SIZE_OF(a)
2297− p = arrStart `plusPtr` off
2160+ p = arrStart + off
2298 in ( Array
2161 in ( Array
2299 { arrContents = arrContents
2162 { arrContents = arrContents
2300 , arrStart = arrStart
2163 , arrStart = arrStart
@@ -2303,7 +2166,7 @@ splitAt i arr@Array{..} =
2305 { arrContents = arrContents
2168 { arrContents = arrContents
2306− , arrStart = arrStart `plusPtr` off
2169+ , arrStart = p
2307 , aEnd = aEnd
2170 , aEnd = aEnd
2308 , aBound = aBound
2171 , aBound = aBound
@@ -2326,7 +2189,7 @@ castUnsafe ::
2327 Array a -> Array b
2190 Array a -> Array b
2328castUnsafe (Array contents start end bound) =
2191castUnsafe (Array contents start end bound) =
2329− Array contents (castPtr start) (castPtr end) (castPtr bound)
2192+ Array (castContents contents) start end bound
2331-- | Cast an @Array a@ into an @Array Word8@.
2194-- | Cast an @Array a@ into an @Array Word8@.
@@ -2349,44 +2212,82 @@ cast arr =
2349 then Nothing
2212 then Nothing
2350 else Just $ castUnsafe arr
2213 else Just $ castUnsafe arr
2215+-- XXX We can provide another API for "unsafe" FFI calls passing an unlifted
2216+-- pointer to the FFI call. For unsafe calls we do not need to pin the array.
2217+-- We can pass an unlifted pointer to the FFI routine to avoid GC kicking in
2218+-- before the pointer is wrapped.
2220+-- From the GHC manual:
2222+-- GHC, since version 8.4, guarantees that garbage collection will never occur
2223+-- during an unsafe call, even in the bytecode interpreter, and further
2224+-- guarantees that unsafe calls will be performed in the calling thread. Making
2225+-- it safe to pass heap-allocated objects to unsafe functions.
2227+-- Unsafe because of direct pointer operations. The user must ensure that they
2228+-- are writing within the legal bounds of the array. Should we just name it
2229+-- asPtr, the unsafety is implicit for any pointer operations. And we are safe
2230+-- from Haskell perspective because we will be pinning the memory.
2352−-- | Use an @Array a@ as @Ptr a@.
2232+-- | Use an @Array a@ as @Ptr a@. This is useful when we want to pass an array
2233+-- as a pointer to some operating system call or to a "safe" FFI call.
2235+-- If the array is not pinned it is copied to pinned memory before passing it
2236+-- to the monadic action.
2238+-- /Performance Notes:/ Forces a copy if the array is not pinned. It is advised
2239+-- that the programmer keeps this in mind and creates a pinned array
2240+-- opportunistically before this operation occurs, to avoid the cost of a copy
2354-- /Unsafe/
2243-- /Unsafe/
2356-- /Pre-release/
2245-- /Pre-release/
2358asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b
2247asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b
2359−asPtrUnsafe Array{..} f = do
2248+asPtrUnsafe arr f = do
2249+ let contents = arrContents arr
2250+ !ptr = Ptr (byteArrayContents#
2251+ (unsafeCoerce# (getMutableByteArray# contents)))
2252+ -- XXX Check if the array is pinned, if not, copy it to a pinned array
2253+ -- XXX We should probably pass to the IO action the byte length of the array
2254+ -- as well so that bounds can be checked.
2360− r <- f arrStart
2255+ r <- f (ptr `plusPtr` arrStart arr)
2361− liftIO $ touch arrContents
2256+ liftIO $ touch contents
2362 return r
2257 return r
2364-------------------------------------------------------------------------------
2259-------------------------------------------------------------------------------
2365-- Equality
2260-- Equality
2366-------------------------------------------------------------------------------
2261-------------------------------------------------------------------------------
2368−-- | Compare if two arrays are equal.
2263+-- | Compare the length of the arrays. If the length is equal, compare the
2264+-- lexicographical ordering of two underlying byte arrays
2370-- /Pre-release/
2266-- /Pre-release/
2371{-# INLINE cmp #-}
2267{-# INLINE cmp #-}
2372−cmp :: MonadIO m => Array a -> Array a -> m Bool
2268+cmp :: MonadIO m => Array a -> Array a -> m Ordering
2373cmp arr1 arr2 =
2269cmp arr1 arr2 =
2374− liftIO $ do
2270+ liftIO
2375− let ptr1 = arrStart arr1
2271+ $ do
2376− let ptr2 = arrStart arr2
2272+ let marr1 = getMutableByteArray# (arrContents arr1)
2377− let len1 = aEnd arr1 `minusPtr` ptr1
2273+ marr2 = getMutableByteArray# (arrContents arr2)
2378− let len2 = aEnd arr2 `minusPtr` ptr2
2274+ !(I# st1#) = arrStart arr1
2379−
2275+ !(I# st2#) = arrStart arr2
2380− if len1 == len2
2276+ !(I# len#) = byteLength arr1
2381− then
2277+ case compare (byteLength arr1) (byteLength arr2) of
2384− else do
2278+ EQ -> do
2385− r <- memcmp (castPtr ptr1) (castPtr ptr2) len1
2279+ r <- liftIO $ IO $ \s# ->
2386− touch (arrContents arr1)
2280+ let res =
2387− touch (arrContents arr2)
2281+ I#
2282+ (compareByteArrays#
2283+ (unsafeCoerce# marr1)
2285+ (unsafeCoerce# marr2)
2388− return r
2289+ return $ compare r 0
2389− else return False
2290+ x -> return x
2391-------------------------------------------------------------------------------
2292-------------------------------------------------------------------------------
2392-- NFData
2293-- NFData
@@ -2408,12 +2309,10 @@ instance NFData1 Array where
2408{-# INLINE strip #-}
2309{-# INLINE strip #-}
2409strip :: forall a m. (Storable a, MonadIO m) =>
2310strip :: forall a m. (Storable a, MonadIO m) =>
2410 (a -> Bool) -> Array a -> m (Array a)
2311 (a -> Bool) -> Array a -> m (Array a)
2411−strip eq arr@Array{..} = do
2312+strip eq arr@Array{..} = liftIO $ do
2412− st <- liftIO $ getStart arrStart
2313+ st <- getStart arrStart
2413− end <- liftIO $ getLast aEnd st
2314+ end <- getLast aEnd st
2416− return arr {arrStart = st, aEnd = end, aBound = end}
2315+ return arr {arrStart = st, aEnd = end, aBound = end}
@@ -2430,17 +2329,17 @@ strip eq arr@Array{..} = do
2430 getStart cur = do
2329 getStart cur = do
2431 if cur < aEnd
2330 if cur < aEnd
2433− r <- peek cur
2332+ r <- peekWith arrContents cur
2435− then getStart (PTR_NEXT(cur, a))
2334+ then getStart (INDEX_NEXT(cur,a))
2436 else return cur
2335 else return cur
2437 else return cur
2336 else return cur
2439 getLast cur low = do
2338 getLast cur low = do
2440 if cur > low
2339 if cur > low
2442− let prev = PTR_PREV(cur,a)
2341+ let prev = INDEX_PREV(cur,a)
2443− r <- peek prev
2342+ r <- peekWith arrContents prev
2445 then getLast prev low
2344 then getLast prev low
2446 else return cur
2345 else return cur