@@ -18,8 +18,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
1818 -- $arrayNotes
1919 Array (..)
2020 , ArrayContents
21− , arrayToFptrContents
22− , fptrToArrayContents
2321 , nilArrayContents
2422 , touch
2523
@@ -29,9 +27,10 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
2927
3028 -- *** Uninitialized Arrays
3129 , newArray
30+ , newPinnedArrayBytes
3231 , newArrayAligned
33− , newArrayAlignedUnmanaged
3432 , newArrayWith
33+ , newAlignedArrayContents
3534
3635 -- *** Initialized Arrays
3736 , withNewArrayUnsafe
@@ -43,7 +42,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
4342 , writeNUnsafe
4443 , writeN
4544 , writeNAligned
46− , writeNAlignedUnmanaged
4745
4846 , writeWith
4947 , write
@@ -52,7 +50,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
5250 -- , writeRev
5351
5452 -- ** From containers
55− , fromForeignPtrUnsafe
5653 , fromListN
5754 , fromList
5855 , fromListRevN
@@ -98,7 +95,6 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
9895 -- * Eliminating and Reading
9996
10097 -- ** To streams
101− , ReadUState(..)
10298 , read
10399 , readRevWith
104100 , readRev
@@ -194,6 +190,8 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
194190 , spliceWith
195191 , splice
196192 , spliceExp
193+ , spliceUnsafe
194+ , putSliceUnsafe
197195 -- , putSlice
198196 -- , appendSlice
199197 -- , appendSliceFrom
@@ -214,10 +212,6 @@ where
214212#include "ArrayMacros.h"
215213#include "MachDeps.h"
216214
217−#ifdef USE_C_MALLOC
218−#define USE_FOREIGN_PTR
219−#endif
220−
221215import Control.Exception (assert)
222216import Control.DeepSeq (NFData(..), NFData1(..))
223217import Control.Monad (when, void)
@@ -228,27 +222,27 @@ import Data.Semigroup (Semigroup(..))
228222#endif
229223import Data.Word (Word8)
230224import Foreign.C.Types (CSize(..), CInt(..))
231−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
232−#ifndef USE_FOREIGN_PTR
233−import Foreign.Marshal.Alloc (mallocBytes)
234−#endif
235−import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)
225+import Foreign.Ptr (plusPtr, minusPtr, nullPtr)
226+import Streamly.Internal.Control.Exception (assertM)
236227import Streamly.Internal.Data.Unboxed
237− ( Storable, alignment, peek, poke, sizeOf
228+ ( ArrayContents(..)
229+ , Storable
230+ , alignment
231+ , castContents
232+ , getMutableByteArray#
233+ , peekWith
234+ , pokeWith
235+ , sizeOf
236+ , touch
238237 )
239238import GHC.Base
240− ( touch#, IO(..), byteArrayContents#
239+ ( IO(..), byteArrayContents#
241240 , Int(..), newAlignedPinnedByteArray#
241+ , copyMutableByteArray#, compareByteArrays#
242242 )
243−#ifndef USE_FOREIGN_PTR
244−import GHC.Base (RealWorld, MutableByteArray#)
245−#endif
246243import GHC.Base (noinline)
247244import GHC.Exts (unsafeCoerce#)
248−import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
249−#ifdef USE_C_MALLOC
250−import GHC.ForeignPtr (mallocForeignPtrAlignedBytes)
251−#endif
245+
252246import GHC.Ptr (Ptr(..))
253247
254248import Streamly.Internal.Data.Fold.Type (Fold(..))
@@ -267,9 +261,6 @@ import qualified Streamly.Internal.Data.Producer as Producer
267261import qualified Streamly.Internal.Data.Stream.StreamD.Type as D
268262import qualified Streamly.Internal.Data.Stream.StreamK.Type as K
269263import qualified Streamly.Internal.Data.Stream.Type as Stream
270−#ifdef USE_FOREIGN_PTR
271−import qualified Streamly.Internal.Foreign.Malloc as Malloc
272−#endif
273264import qualified Prelude
274265
275266import Prelude hiding
@@ -315,37 +306,6 @@ memcmp p1 p2 len = do
315306 r <- c_memcmp p1 p2 (fromIntegral len)
316307 return $ r == 0
317308
318−-------------------------------------------------------------------------------
319−-- Array Contents
320−-------------------------------------------------------------------------------
321−
322−-- We support using ForeignPtrContents or MutableByteArray.
323−
324−#ifdef USE_FOREIGN_PTR
325−newtype ArrayContents = ArrayContents ForeignPtrContents
326−#define UNPACKIF
327−#else
328−-- XXX can use UnliftedNewtypes
329−data ArrayContents = ArrayContents !(MutableByteArray# RealWorld)
330−#define UNPACKIF {-# UNPACK #-}
331−#endif
332−
333−{-# INLINE touch #-}
334−touch :: ArrayContents -> IO ()
335−touch (ArrayContents contents) =
336− IO $ \s -> case touch# contents s of s' -> (# s', () #)
337−
338−fptrToArrayContents :: ForeignPtrContents -> ArrayContents
339−arrayToFptrContents :: ArrayContents -> ForeignPtrContents
340−#ifdef USE_FOREIGN_PTR
341−fptrToArrayContents = ArrayContents
342−arrayToFptrContents (ArrayContents contents) = contents
343−#else
344−fptrToArrayContents (PlainPtr mbarr) = ArrayContents mbarr
345−fptrToArrayContents _ = error "Unsupported foreign ptr"
346−arrayToFptrContents (ArrayContents contents) = PlainPtr contents
347−#endif
348−
349309-------------------------------------------------------------------------------
350310-- Array Data Type
351311-------------------------------------------------------------------------------
@@ -380,11 +340,15 @@ data Array a =
380340#ifdef DEVBUILD
381341 Storable a =>
382342#endif
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.
383345 Array
384− { arrContents :: UNPACKIF !ArrayContents
385− , arrStart :: {-# UNPACK #-} !(Ptr a) -- ^ first address
386− , aEnd :: {-# UNPACK #-} !(Ptr a) -- ^ first unused address
387− , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory
346+ { arrContents :: {-# UNPACK #-} !(ArrayContents a)
347+ , arrStart :: {-# UNPACK #-} !Int -- ^ index into arrContents
348+ , aEnd :: {-# UNPACK #-} !Int -- ^ index into arrContents
349+ -- Represents the first invalid index of
350+ -- the array.
351+ , aBound :: {-# UNPACK #-} !Int -- ^ first invalid index of arrContents.
388352 }
389353
390354-------------------------------------------------------------------------------
@@ -413,101 +377,37 @@ data Array a =
413377-- /Pre-release/
414378{-# INLINE newArrayWith #-}
415379newArrayWith :: 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)
417381newArrayWith alloc alignSize count = do
418382 let size = max (count * SIZE_OF(a)) 0
419− (contents, p) <- alloc size alignSize
383+ contents <- alloc size alignSize
420384 return $ Array
421385 { arrContents = contents
422− , arrStart = p
423− , aEnd = p
424− , aBound = p `plusPtr` size
386+ , arrStart = 0
387+ , aEnd = 0
388+ , aBound = size
425389 }
426390
427−newAlignedArrayContents :: Int -> Int -> IO (ArrayContents, Ptr a)
428−#ifdef USE_C_MALLOC
429−newAlignedArrayContents size align = do
430− (ForeignPtr addr contents) <- mallocForeignPtrAlignedBytes size align
431− return (ArrayContents contents, Ptr addr)
432−#else
433−newAlignedArrayContents size _align | size < 0 =
391+newAlignedArrayContents :: Int -> Int -> IO (ArrayContents a)
392+newAlignedArrayContents nbytes _align | nbytes < 0 =
434393 errorWithoutStackTrace "newAlignedArrayContents: size must be >= 0"
435−newAlignedArrayContents (I# size) (I# align) = IO $ \s ->
436− case newAlignedPinnedByteArray# size align s of
394+newAlignedArrayContents (I# nbytes) (I# align) = IO $ \s ->
395+ case newAlignedPinnedByteArray# nbytes align s of
437396 (# s', mbarr# #) ->
438− let p = Ptr (byteArrayContents# (unsafeCoerce# mbarr#))
439−#ifdef USE_FOREIGN_PTR
440− c = ArrayContents (PlainPtr mbarr#)
441−#else
442− c = ArrayContents mbarr#
443−#endif
444− in (# s', (c, p) #)
445−#endif
397+ let c = ArrayContents mbarr#
398+ in (# s', c #)
446399
447400{-# NOINLINE nilArrayContents #-}
448−nilArrayContents :: ArrayContents
401+nilArrayContents :: ArrayContents a
449402nilArrayContents =
450− fst $ unsafePerformIO $ newAlignedArrayContents 0 0
403+ unsafePerformIO $ newAlignedArrayContents 0 0
451404
452405nil ::
453406#ifdef DEVBUILD
454407 Storable a =>
455408#endif
456409 Array a
457−nil = Array nilArrayContents nullPtr nullPtr nullPtr
458−
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.
462−--
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
465−-- supported.
466−--
467−-- /Pre-release/
468−--
469−{-# INLINE fromForeignPtrUnsafe #-}
470−fromForeignPtrUnsafe ::
471−#ifdef DEVBUILD
472− Storable a =>
473−#endif
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)
480−
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.
485−--
486−-- /Internal/
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
493−
494− where
495−
496− mallocForeignPtrAlignedUnmanagedBytes size align = do
497− ForeignPtr addr contents <-
498− liftIO $ Malloc.mallocForeignPtrAlignedUnmanagedBytes size align
499− return (ArrayContents contents, Ptr addr)
500−#else
501−newArrayAlignedUnmanaged _align count = do
502− let size = max (count * SIZE_OF(a)) 0
503− p <- liftIO $ mallocBytes size
504− return $ Array
505− { arrContents = nilArrayContents
506− , arrStart = p
507− , aEnd = p
508− , aBound = p `plusPtr` size
509− }
510−#endif
410+nil = Array nilArrayContents 0 0 0
511411
512412-- | Like 'newArrayWith' but using an allocator that aligns the memory to the
513413-- alignment dictated by the 'Storable' instance of the type.
@@ -528,6 +428,23 @@ newArrayAligned = newArrayWith (\s a -> liftIO $ newAlignedArrayContents s a)
528428newArray :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)
529429newArray = newArrayAligned (alignment (undefined :: a))
530430
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.
434+--
435+-- /Pre-release/
436+{-# INLINE newPinnedArrayBytes #-}
437+newPinnedArrayBytes :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)
438+newPinnedArrayBytes bytes = do
439+ contents <-
440+ liftIO $ newAlignedArrayContents bytes (alignment (undefined :: a))
441+ return $ Array
442+ { arrContents = contents
443+ , arrStart = 0
444+ , aEnd = 0
445+ , aBound = bytes
446+ }
447+
531448-- | Allocate an Array of the given size and run an IO action passing the array
532449-- start pointer.
533450--
@@ -551,25 +468,15 @@ withNewArrayUnsafe count f = do
551468{-# INLINE putIndexUnsafe #-}
552469putIndexUnsafe :: forall m a. (MonadIO m, Storable a)
553470 => Int -> a -> Array a -> m ()
554−putIndexUnsafe i x arr@(Array{..}) =
555− asPtrUnsafe arr $ \ptr -> do
556− let elemPtr = PTR_INDEX(ptr,i,a)
557− assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ())
558− liftIO $ poke elemPtr x
471+putIndexUnsafe i x (Array {..}) = do
472+ let index = INDEX_OF(arrStart, i, a)
473+ assert (i >= 0 && INDEX_VALID(index, aEnd, a)) (return ())
474+ liftIO $ pokeWith arrContents index x
559475
560476invalidIndex :: String -> Int -> a
561477invalidIndex label i =
562478 error $ label ++ ": invalid array index " ++ show i
563479
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
572−
573480-- | /O(1)/ Write the given element at the given index in the array.
574481-- Performs in-place mutation of the array.
575482--
@@ -579,10 +486,12 @@ putIndexPtr start end i x = do
579486--
580487-- /Pre-release/
581488{-# INLINE putIndex #-}
582−putIndex :: (MonadIO m, Storable a) => Int -> a -> Array a -> m ()
583−putIndex i x arr =
584− asPtrUnsafe arr
585− $ \p -> putIndexPtr p (aEnd arr) i x
489+putIndex :: forall m a. (MonadIO m, Storable a) => Int -> a -> Array a -> m ()
490+putIndex i x Array{..} = do
491+ let index = INDEX_OF(arrStart,i,a)
492+ if i >= 0 && INDEX_VALID(index,aEnd,a)
493+ then liftIO $ pokeWith arrContents index x
494+ else invalidIndex "putIndex" i
586495
587496-- | Write an input stream of (index, value) pairs to an array. Throws an
588497-- error if any index is out of bounds.
@@ -591,51 +500,40 @@ putIndex i x arr =
591500{-# INLINE putIndices #-}
592501putIndices :: forall m a. (MonadIO m, Storable a)
593502 => Array a -> Fold m (Int, a) ()
594−putIndices Array{..} = FL.rmapM extract $ FL.foldlM' step initial
503+putIndices arr = FL.foldlM' step (return ())
595504
596505 where
597506
598− initial = return ()
599−
600− step () (i, x) = liftIO (putIndexPtr arrStart aEnd i x)
601−
602− extract () = liftIO $ touch arrContents
507+ step () (i, x) = liftIO (putIndex i x arr)
603508
604509-- | Modify a given index of an array using a modifier function.
605510--
606511-- /Pre-release/
607512modifyIndexUnsafe :: forall m a b. (MonadIO m, Storable a) =>
608513 Int -> (a -> (a, b)) -> Array a -> m b
609−modifyIndexUnsafe i f arr@(Array{..}) = do
610− liftIO $ asPtrUnsafe arr $ \ptr -> do
611− let elemPtr = PTR_INDEX(ptr,i,a)
612− assert (i >= 0 && PTR_NEXT(elemPtr,a) <= aEnd) (return ())
613− r <- peek elemPtr
514+modifyIndexUnsafe i f (Array{..}) = liftIO $ do
515+ let index = INDEX_OF(arrStart,i,a)
516+ assert (i >= 0 && INDEX_NEXT(index,a) <= aEnd) (return ())
517+ r <- peekWith arrContents index
614518 let (x, res) = f r
615− poke elemPtr x
519+ pokeWith arrContents index x
616520 return res
617521
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)
624− then do
625− r <- peek elemPtr
626− let (x, res) = f r
627− poke elemPtr x
628− return res
629− else invalidIndex "modifyIndex" i
630−
631522-- | Modify a given index of an array using a modifier function.
632523--
633524-- /Pre-release/
634525modifyIndex :: forall m a b. (MonadIO m, Storable a) =>
635526 Int -> (a -> (a, b)) -> Array a -> m b
636−modifyIndex i f arr@(Array{..}) = do
637− liftIO $ asPtrUnsafe arr $ \ptr -> do
638− modifyIndexPtr i f ptr aEnd
527+modifyIndex i f Array{..} = do
528+ let index = INDEX_OF(arrStart,i,a)
529+ if i >= 0 && INDEX_VALID(index,aEnd,a)
530+ then liftIO $ do
531+ r <- peekWith arrContents index
532+ let (x, res) = f r
533+ pokeWith arrContents index x
534+ return res
535+ else invalidIndex "modifyIndex" i
536+
639537
640538-- | Modify the array indices generated by the supplied stream.
641539--
@@ -643,41 +541,39 @@ modifyIndex i f arr@(Array{..}) = do
643541{-# INLINE modifyIndices #-}
644542modifyIndices :: forall m a . (MonadIO m, Storable a)
645543 => (Int -> a -> a) -> Array a -> Fold m Int ()
646−modifyIndices f Array{..} = Fold step initial extract
544+modifyIndices f arr = FL.foldlM' step initial
647545
648546 where
649547
650− initial = return $ FL.Partial ()
548+ initial = return ()
651549
652550 step () i =
653551 let f1 x = (f i x, ())
654− in FL.Partial <$> liftIO (modifyIndexPtr i f1 arrStart aEnd)
655−
656− extract () = liftIO $ touch arrContents
552+ in modifyIndex i f1 arr
657553
658554-- | Modify each element of an array using the supplied modifier function.
659555--
660556-- /Pre-release/
661557modify :: forall m a. (MonadIO m, Storable a)
662558 => (a -> a) -> Array a -> m ()
663−modify f arr@Array{..} = liftIO $
664− asPtrUnsafe arr go
559+modify f Array{..} = liftIO $
560+ go arrStart
665561
666562 where
667563
668− go ptr =
669− when (PTR_VALID(ptr,aEnd,a)) $ do
670− r <- peek ptr
671− poke ptr (f r)
672− go (PTR_NEXT(ptr,a))
564+ go i =
565+ when (INDEX_VALID(i,aEnd,a)) $ do
566+ r <- peekWith arrContents i
567+ pokeWith arrContents i (f r)
568+ go (INDEX_NEXT(i,a))
673569
674−{-# INLINE swapPtrs #-}
675−swapPtrs :: Storable a => Ptr a -> Ptr a -> IO ()
676−swapPtrs ptr1 ptr2 = do
677− r1 <- peek ptr1
678− r2 <- peek ptr2
679− poke ptr1 r2
680− poke ptr2 r1
570+{-# INLINE swapArrayByteIndices #-}
571+swapArrayByteIndices :: Storable a => ArrayContents a -> Int -> Int -> IO ()
572+swapArrayByteIndices arrContents i1 i2 = do
573+ r1 <- peekWith arrContents i1
574+ r2 <- peekWith arrContents i2
575+ pokeWith arrContents i1 r2
576+ pokeWith arrContents i2 r1
681577
682578-- | Swap the elements at two indices without validating the indices.
683579--
@@ -687,11 +583,10 @@ swapPtrs ptr1 ptr2 = do
687583{-# INLINE unsafeSwapIndices #-}
688584unsafeSwapIndices :: forall m a. (MonadIO m, Storable a)
689585 => Int -> Int -> Array a -> m ()
690−unsafeSwapIndices i1 i2 arr = liftIO $ do
691− asPtrUnsafe arr $ \ptr -> do
692− let ptr1 = PTR_INDEX(ptr,i1,a)
693− ptr2 = PTR_INDEX(ptr,i2,a)
694− swapPtrs ptr1 (ptr2 :: Ptr a)
586+unsafeSwapIndices i1 i2 Array{..} = liftIO $ do
587+ let t1 = INDEX_OF(arrStart,i1,a)
588+ t2 = INDEX_OF(arrStart,i2,a)
589+ swapArrayByteIndices arrContents t1 t2
695590
696591-- | Swap the elements at two indices.
697592--
@@ -699,13 +594,13 @@ unsafeSwapIndices i1 i2 arr = liftIO $ do
699594swapIndices :: forall m a. (MonadIO m, Storable a)
700595 => Int -> Int -> Array a -> m ()
701596swapIndices i1 i2 Array{..} = liftIO $ do
702− let ptr1 = PTR_INDEX(arrStart,i1,a)
703− ptr2 = PTR_INDEX(arrStart,i2,a)
704− when (i1 < 0 || PTR_INVALID(ptr1,aEnd,a))
597+ let t1 = INDEX_OF(arrStart,i1,a)
598+ t2 = INDEX_OF(arrStart,i2,a)
599+ when (i1 < 0 || INDEX_INVALID(t1,aEnd,a))
705600 $ invalidIndex "swapIndices" i1
706− when (i2 < 0 || PTR_INVALID(ptr2,aEnd,a))
601+ when (i2 < 0 || INDEX_INVALID(t2,aEnd,a))
707602 $ invalidIndex "swapIndices" i2
708− swapPtrs ptr1 (ptr2 :: Ptr a)
603+ swapArrayByteIndices arrContents t1 t2
709604
710605-------------------------------------------------------------------------------
711606-- Rounding
@@ -797,31 +692,38 @@ roundDownTo elemSize size = size - (size `mod` elemSize)
797692-- XXX See if resizing can be implemented by reading the old array as a stream
798693-- and then using writeN to the new array.
799694--
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.
698+--
800699{-# NOINLINE reallocAligned #-}
801700reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a)
802−reallocAligned elemSize alignSize newCapacity Array{..} = do
803− assert (aEnd <= aBound) (return ())
701+reallocAligned elemSize alignSize newCapacityInBytes Array{..} = do
702+ assertM (aEnd <= aBound)
804703
805704 -- Allocate new array
806− let newCapMax = roundUpLargeArray newCapacity
807− (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
705+ let newCapMaxInBytes = roundUpLargeArray newCapacityInBytes
706+ contents <- newAlignedArrayContents newCapMaxInBytes alignSize
707+ let !(ArrayContents mbarrFrom#) = arrContents
708+ !(ArrayContents mbarrTo#) = contents
808709
809710 -- Copy old data
810711 let oldStart = arrStart
811− oldSize = aEnd `minusPtr` oldStart
812− newCap = roundDownTo elemSize newCapMax
813− newLen = min oldSize newCap
814− assert (oldSize `mod` elemSize == 0) (return ())
815− assert (newLen >= 0) (return ())
816− assert (newLen `mod` elemSize == 0) (return ())
817− memcpy (castPtr pNew) (castPtr oldStart) newLen
818− touch arrContents
712+ !(I# oldStartInBytes#) = oldStart
713+ oldSizeInBytes = aEnd - oldStart
714+ newCapInBytes = roundDownTo elemSize newCapMaxInBytes
715+ !newLenInBytes@(I# newLenInBytes#) = min oldSizeInBytes newCapInBytes
716+ assert (oldSizeInBytes `mod` elemSize == 0) (return ())
717+ assert (newLenInBytes >= 0) (return ())
718+ assert (newLenInBytes `mod` elemSize == 0) (return ())
719+ IO $ \s# -> (# copyMutableByteArray# mbarrFrom# oldStartInBytes#
720+ mbarrTo# 0# newLenInBytes# s#, () #)
819721
820722 return $ Array
821− { arrStart = pNew
723+ { arrStart = 0
822724 , arrContents = contents
823− , aEnd = pNew `plusPtr` newLen
824− , aBound = pNew `plusPtr` newCap
725+ , aEnd = newLenInBytes
726+ , aBound = newCapInBytes
825727 }
826728
827729-- | @realloc newCapacity array@ reallocates the array to the specified
@@ -834,10 +736,10 @@ reallocAligned elemSize alignSize newCapacity Array{..} = do
834736--
835737{-# INLINABLE realloc #-}
836738realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
837−realloc n arr =
838− liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
739+realloc bytes arr =
740+ liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) bytes arr
839741
840−-- | @reallocWith label capSizer minIncrement array@. The label is used
742+-- | @reallocWith label capSizer minIncrBytes array@. The label is used
841743-- in error messages and the capSizer is used to determine the capacity of the
842744-- new array in bytes given the current byte length of the array.
843745reallocWith :: forall m a. (MonadIO m , Storable a) =>
@@ -846,22 +748,24 @@ reallocWith :: forall m a. (MonadIO m , Storable a) =>
846748 -> Int
847749 -> Array a
848750 -> m (Array a)
849−reallocWith label capSizer minIncr arr = do
850− let oldSize = aEnd arr `minusPtr` arrStart arr
851− newCap = capSizer oldSize
852− newSize = oldSize + minIncr
853− safeCap = max newCap newSize
854− assert (newCap >= newSize || error (badSize newSize)) (return ())
855− realloc safeCap arr
751+reallocWith label capSizer minIncrBytes arr = do
752+ let oldSizeBytes = aEnd arr - arrStart arr
753+ newCapBytes = capSizer oldSizeBytes
754+ newSizeBytes = oldSizeBytes + minIncrBytes
755+ safeCapBytes = max newCapBytes newSizeBytes
756+ assertM (safeCapBytes >= newSizeBytes || error (badSize newSizeBytes))
757+
758+ realloc safeCapBytes arr
856759
857760 where
858761
859− badSize newSize = concat
860− [ label
861− , ": new array size is less than required size "
862− , show newSize
863− , ". Please check the sizing function passed."
864− ]
762+ badSize newSize =
763+ concat
764+ [ label
765+ , ": new array size (in bytes) is less than required size "
766+ , show newSize
767+ , ". Please check the sizing function passed."
768+ ]
865769
866770-- | @resize newCapacity array@ changes the total capacity of the array so that
867771-- it is enough to hold the specified number of elements. Nothing is done if
@@ -874,27 +778,27 @@ reallocWith label capSizer minIncr arr = do
874778{-# INLINE resize #-}
875779resize :: forall m a. (MonadIO m, Storable a) =>
876780 Int -> Array a -> m (Array a)
877−resize n arr@Array{..} = do
878− let req = SIZE_OF(a) * n
879− len = aEnd `minusPtr` arrStart
781+resize nElems arr@Array{..} = do
782+ let req = SIZE_OF(a) * nElems
783+ len = aEnd - arrStart
880784 if req < len
881785 then return arr
882786 else realloc req arr
883787
884−-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
885−-- it is rounded up to the closest power of 2.
788+-- | Like 'resize' but if the byte capacity is more than 'largeObjectThreshold'
789+-- then it is rounded up to the closest power of 2.
886790--
887791-- /Pre-release/
888792{-# INLINE resizeExp #-}
889793resizeExp :: forall m a. (MonadIO m, Storable a) =>
890794 Int -> Array a -> m (Array a)
891−resizeExp n arr@Array{..} = do
892− let req = roundUpLargeArray (SIZE_OF(a) * n)
795+resizeExp nElems arr@Array{..} = do
796+ let req = roundUpLargeArray (SIZE_OF(a) * nElems)
893797 req1 =
894798 if req > largeObjectThreshold
895799 then roundUpToPower2 req
896800 else req
897− len = aEnd `minusPtr` arrStart
801+ len = aEnd - arrStart
898802 if req1 < len
899803 then return arr
900804 else realloc req1 arr
@@ -912,10 +816,10 @@ rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a)
912816rightSize arr@Array{..} = do
913817 assert (aEnd <= aBound) (return ())
914818 let start = arrStart
915− len = aEnd `minusPtr` start
916− capacity = aBound `minusPtr` start
819+ len = aEnd - start
820+ capacity = aBound - start
917821 target = roundUpLargeArray len
918− waste = aBound `minusPtr` aEnd
822+ waste = aBound - aEnd
919823 assert (target >= len) (return ())
920824 assert (len `mod` SIZE_OF(a) == 0) (return ())
921825 -- We trade off some wastage (25%) to avoid reallocations and copying.
@@ -940,11 +844,10 @@ rightSize arr@Array{..} = do
940844--
941845-- /Internal/
942846{-# 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)
944848snocNewEnd newEnd arr@Array{..} x = liftIO $ do
945849 assert (newEnd <= aBound) (return ())
946− poke aEnd x
947− touch arrContents
850+ pokeWith arrContents aEnd x
948851 return $ arr {aEnd = newEnd}
949852
950853-- | Really really unsafe, appends the element into the first array, may
@@ -955,7 +858,7 @@ snocNewEnd newEnd arr@Array{..} x = liftIO $ do
955858{-# INLINE snocUnsafe #-}
956859snocUnsafe :: forall m a. (MonadIO m, Storable a) =>
957860 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
959862
960863-- | Like 'snoc' but does not reallocate when pre-allocated array capacity
961864-- becomes full.
@@ -965,7 +868,7 @@ snocUnsafe arr@Array{..} = snocNewEnd (PTR_NEXT(aEnd,a)) arr
965868snocMay :: forall m a. (MonadIO m, Storable a) =>
966869 Array a -> a -> m (Maybe (Array a))
967870snocMay arr@Array{..} x = liftIO $ do
968− let newEnd = PTR_NEXT(aEnd,a)
871+ let newEnd = INDEX_NEXT(aEnd,a)
969872 if newEnd <= aBound
970873 then Just <$> snocNewEnd newEnd arr x
971874 else return Nothing
@@ -1001,7 +904,7 @@ snocWith :: forall m a. (MonadIO m, Storable a) =>
1001904 -> a
1002905 -> m (Array a)
1003906snocWith allocSize arr x = liftIO $ do
1004− let newEnd = PTR_NEXT(aEnd arr,a)
907+ let newEnd = INDEX_NEXT(aEnd arr,a)
1005908 if newEnd <= aBound arr
1006909 then snocNewEnd newEnd arr x
1007910 else snocWithRealloc allocSize arr x
@@ -1049,42 +952,27 @@ snoc = snocWith f
1049952-- Random reads
1050953-------------------------------------------------------------------------------
1051954
955+-- XXX Can this be deduplicated with array/foreign
956+
1052957-- | Return the element at the specified index without checking the bounds.
1053958--
1054959-- Unsafe because it does not check the bounds of the array.
1055960{-# INLINE_NORMAL getIndexUnsafe #-}
1056961getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
1057−getIndexUnsafe i arr@(Array {..}) =
1058− asPtrUnsafe arr $ \ptr -> do
1059− let elemPtr = PTR_INDEX(ptr,i,a)
1060− assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ())
1061− liftIO $ peek elemPtr
1062−
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
962+getIndexUnsafe i (Array {..}) = do
963+ let index = INDEX_OF(arrStart,i,a)
964+ assert (i >= 0 && INDEX_VALID(index,aEnd,a)) (return ())
965+ liftIO $ peekWith arrContents index
1071966
1072967-- | /O(1)/ Lookup the element at the given index. Index starts from 0.
1073968--
1074969{-# INLINE getIndex #-}
1075−getIndex :: (MonadIO m, Storable a) => Int -> Array a -> m a
1076−getIndex i arr =
1077− asPtrUnsafe arr
1078− $ \p -> getIndexPtr p (aEnd arr) i
1079−
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
970+getIndex :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
971+getIndex i Array{..} = do
972+ let index = INDEX_OF(arrStart,i,a)
973+ if i >= 0 && INDEX_VALID(index,aEnd,a)
974+ then liftIO $ peekWith arrContents index
975+ else invalidIndex "getIndex" i
1088976
1089977-- | /O(1)/ Lookup the element at the given index from the end of the array.
1090978-- Index starts from 0.
@@ -1092,10 +980,12 @@ getIndexPtrRev start end i = do
1092980-- Slightly faster than computing the forward index and using getIndex.
1093981--
1094982{-# INLINE getIndexRev #-}
1095−getIndexRev :: (MonadIO m, Storable a) => Int -> Array a -> m a
1096−getIndexRev i arr =
1097− asPtrUnsafe arr
1098− $ \p -> getIndexPtrRev p (aEnd arr) i
983+getIndexRev :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a
984+getIndexRev i Array{..} = do
985+ let index = RINDEX_OF(aEnd,i,a)
986+ if i >= 0 && index >= arrStart
987+ then liftIO $ peekWith arrContents index
988+ else invalidIndex "getIndexRev" i
1099989
1100990data GetIndicesState contents start end st =
1101991 GetIndicesState contents start end st
@@ -1112,20 +1002,18 @@ getIndicesD liftio (D.Stream stepi sti) = Unfold step inject
11121002
11131003 where
11141004
1115− inject (Array contents start (Ptr end) _) =
1116− return $ GetIndicesState contents start (Ptr end) sti
1005+ inject (Array contents start end _) =
1006+ return $ GetIndicesState contents start end sti
11171007
11181008 {-# INLINE_LATE step #-}
11191009 step (GetIndicesState contents start end st) = do
11201010 r <- stepi defState st
11211011 case r of
11221012 D.Yield i s -> do
1123− x <- liftio $ getIndexPtr start end i
1013+ x <- liftio $ getIndex i (Array contents start end undefined)
11241014 return $ D.Yield x (GetIndicesState contents start end s)
11251015 D.Skip s -> return $ D.Skip (GetIndicesState contents start end s)
1126− D.Stop -> do
1127− liftio $ touch contents
1128− return D.Stop
1016+ D.Stop -> return D.Stop
11291017
11301018{-# INLINE getIndices #-}
11311019getIndices :: (MonadIO m, Storable a) => Stream m Int -> Unfold m (Array a) a
@@ -1151,8 +1039,8 @@ getSliceUnsafe :: forall a. Storable a
11511039 -> Array a
11521040 -> Array a
11531041getSliceUnsafe index len (Array contents start e _) =
1154− let fp1 = PTR_INDEX(start,index,a)
1155− end = fp1 `plusPtr` (len * SIZE_OF(a))
1042+ let fp1 = INDEX_OF(start,index,a)
1043+ end = fp1 + (len * SIZE_OF(a))
11561044 in assert
11571045 (index >= 0 && len >= 0 && end <= e)
11581046 -- Note: In a slice we always use bound = end so that the slice
@@ -1170,8 +1058,8 @@ getSlice :: forall a. Storable a =>
11701058 -> Array a
11711059 -> Array a
11721060getSlice index len (Array contents start e _) =
1173− let fp1 = PTR_INDEX(start,index,a)
1174− end = fp1 `plusPtr` (len * SIZE_OF(a))
1061+ let fp1 = INDEX_OF(start,index,a)
1062+ end = fp1 + (len * SIZE_OF(a))
11751063 in if index >= 0 && len >= 0 && end <= e
11761064 -- Note: In a slice we always use bound = end so that the slice user
11771065 -- cannot overwrite elements beyond the end of the slice.
@@ -1196,15 +1084,15 @@ getSlice index len (Array contents start e _) =
11961084reverse :: forall m a. (MonadIO m, Storable a) => Array a -> m ()
11971085reverse Array{..} = liftIO $ do
11981086 let l = arrStart
1199− h = PTR_PREV(aEnd,a)
1087+ h = INDEX_PREV(aEnd,a)
12001088 in swap l h
12011089
12021090 where
12031091
12041092 swap l h = do
12051093 when (l < h) $ do
1206− swapPtrs l h
1207− swap (PTR_NEXT(l,a)) (PTR_PREV(h,a))
1094+ swapArrayByteIndices arrContents l h
1095+ swap (INDEX_NEXT(l,a)) (INDEX_PREV(h,a))
12081096
12091097-- | Generate the next permutation of the sequence, returns False if this is
12101098-- the last permutation.
@@ -1226,7 +1114,7 @@ partitionBy f arr@Array{..} = liftIO $ do
12261114 if arrStart >= aEnd
12271115 then return (arr, arr)
12281116 else do
1229− ptr <- go arrStart (PTR_PREV(aEnd,a))
1117+ ptr <- go arrStart (INDEX_PREV(aEnd,a))
12301118 let pl = Array arrContents arrStart ptr ptr
12311119 pr = Array arrContents ptr aEnd aEnd
12321120 return (pl, pr)
@@ -1235,11 +1123,11 @@ partitionBy f arr@Array{..} = liftIO $ do
12351123
12361124 -- Invariant low < high on entry, and on return as well
12371125 moveHigh low high = do
1238− h <- peek high
1126+ h <- peekWith arrContents high
12391127 if f h
12401128 then
12411129 -- Correctly classified, continue the loop
1242− let high1 = PTR_PREV(high,a)
1130+ let high1 = INDEX_PREV(high,a)
12431131 in if low == high1
12441132 then return Nothing
12451133 else moveHigh low high1
@@ -1255,7 +1143,7 @@ partitionBy f arr@Array{..} = liftIO $ do
12551143 -- low <= high
12561144 -- Both low and high are valid locations within the array
12571145 go low high = do
1258− l <- peek low
1146+ l <- peekWith arrContents low
12591147 if f l
12601148 then
12611149 -- low is wrongly classified
@@ -1266,17 +1154,17 @@ partitionBy f arr@Array{..} = liftIO $ do
12661154 case r of
12671155 Nothing -> return low
12681156 Just (high1, h) -> do -- low < high1
1269− poke low h
1270− poke high1 l
1271− let low1 = PTR_NEXT(low,a)
1272− high2 = PTR_PREV(high1,a)
1157+ pokeWith arrContents low h
1158+ pokeWith arrContents high1 l
1159+ let low1 = INDEX_NEXT(low,a)
1160+ high2 = INDEX_PREV(high1,a)
12731161 if low1 <= high2
12741162 then go low1 high2
12751163 else return low1 -- low1 > high2
12761164
12771165 else do
12781166 -- low is correctly classified
1279− let low1 = PTR_NEXT(low,a)
1167+ let low1 = INDEX_NEXT(low,a)
12801168 if low == high
12811169 then return low1
12821170 else go low1 high
@@ -1329,12 +1217,12 @@ mergeBy = undefined
13291217{-# INLINE byteLength #-}
13301218byteLength :: Array a -> Int
13311219byteLength Array{..} =
1332− let len = aEnd `minusPtr` arrStart
1220+ let len = aEnd - arrStart
13331221 in assert (len >= 0) len
13341222
13351223-- Note: try to avoid the use of length in performance sensitive internal
13361224-- 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.
13381226--
13391227-- | /O(1)/ Get the length of the array i.e. the number of elements in the
13401228-- array.
@@ -1357,7 +1245,7 @@ length arr =
13571245{-# INLINE byteCapacity #-}
13581246byteCapacity :: Array a -> Int
13591247byteCapacity Array{..} =
1360− let len = aBound `minusPtr` arrStart
1248+ let len = aBound - arrStart
13611249 in assert (len >= 0) len
13621250
13631251-- | The remaining capacity in the array for appending more elements without
@@ -1367,7 +1255,7 @@ byteCapacity Array{..} =
13671255{-# INLINE bytesFree #-}
13681256bytesFree :: Array a -> Int
13691257bytesFree Array{..} =
1370− let n = aBound `minusPtr` aEnd
1258+ let n = aBound - aEnd
13711259 in assert (n >= 0) n
13721260
13731261-------------------------------------------------------------------------------
@@ -1413,8 +1301,8 @@ arraysOf n (D.Stream step state) =
14131301 r <- step (adaptState gst) st
14141302 case r of
14151303 D.Yield x s -> do
1416− liftIO $ poke end x >> touch contents
1417− let end1 = PTR_NEXT(end,a)
1304+ liftIO $ pokeWith contents end x
1305+ let end1 = INDEX_NEXT(end,a)
14181306 return $
14191307 if end1 >= bound
14201308 then D.Skip
@@ -1447,7 +1335,7 @@ arrayStreamKFromStreamD =
14471335
14481336data FlattenState s contents a =
14491337 OuterLoop s
1450− | InnerLoop s contents !(Ptr a) !(Ptr a)
1338+ | InnerLoop s contents !Int !Int
14511339
14521340-- | Use the "read" unfold instead.
14531341--
@@ -1475,11 +1363,8 @@ flattenArrays (D.Stream step state) = D.Stream step' (OuterLoop state)
14751363 return $ D.Skip $ OuterLoop st
14761364
14771365 step' _ (InnerLoop st contents p end) = do
1478− x <- liftIO $ do
1479− r <- peek p
1480− touch contents
1481− return r
1482− return $ D.Yield x (InnerLoop st contents (PTR_NEXT(p,a)) end)
1366+ x <- liftIO $ peekWith contents p
1367+ return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end)
14831368
14841369-- | Use the "readRev" unfold instead.
14851370--
@@ -1499,7 +1384,7 @@ flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state)
14991384 r <- step (adaptState gst) st
15001385 return $ case r of
15011386 D.Yield Array{..} s ->
1502− let p = PTR_PREV(aEnd,a)
1387+ let p = INDEX_PREV(aEnd,a)
15031388 in D.Skip (InnerLoop s arrContents p arrStart)
15041389 D.Skip s -> D.Skip (OuterLoop s)
15051390 D.Stop -> D.Stop
@@ -1509,47 +1394,50 @@ flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state)
15091394
15101395 step' _ (InnerLoop st contents p start) = do
15111396 x <- liftIO $ do
1512− r <- peek p
1513− touch contents
1397+ r <- peekWith contents p
15141398 return r
1515− let cur = PTR_PREV(p,a)
1399+ let cur = INDEX_PREV(p,a)
15161400 return $ D.Yield x (InnerLoop st contents cur start)
15171401
15181402-------------------------------------------------------------------------------
15191403-- Unfolds
15201404-------------------------------------------------------------------------------
15211405
1522−data ReadUState a = ReadUState
1523− UNPACKIF !ArrayContents -- contents
1524− !(Ptr a) -- end address
1525− !(Ptr a) -- current address
1406+data ArrayUnsafe a = ArrayUnsafe
1407+ {-# UNPACK #-} !(ArrayContents a) -- contents
1408+ {-# UNPACK #-} !Int -- index 1
1409+ {-# UNPACK #-} !Int -- index 2
1410+
1411+toArrayUnsafe :: Array a -> ArrayUnsafe a
1412+toArrayUnsafe (Array contents start end _) = ArrayUnsafe contents start end
15261413
1527−toReadUState :: Array a -> ReadUState a
1528−toReadUState (Array contents start end _) = ReadUState contents end start
1414+fromArrayUnsafe ::
1415+#ifdef DEVBUILD
1416+ Storable a =>
1417+#endif
1418+ ArrayUnsafe a -> Array a
1419+fromArrayUnsafe (ArrayUnsafe contents start end) =
1420+ Array contents start end end
15291421
15301422{-# INLINE_NORMAL producerWith #-}
15311423producerWith ::
15321424 forall m a. (Monad m, Storable a)
15331425 => (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
15351427 where
15361428
15371429 {-# INLINE_LATE step #-}
1538− step (ReadUState contents end cur)
1539− | assert (cur <= end) (cur == end) = liftio $ do
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
1543− return D.Stop
1544− step (ReadUState contents end cur) = do
1430+ step (ArrayUnsafe _ cur end)
1431+ | assert (cur <= end) (cur == end) = return D.Stop
1432+ step (ArrayUnsafe contents cur end) = do
15451433 -- When we use a purely lazy Monad like Identity, we need to force a
15461434 -- few actions for correctness and execution order sanity. We want
15471435 -- the peek to occur right here and not lazily at some later point
15481436 -- because we want the peek to be ordered with respect to the touch.
1549− !x <- liftio $ peek cur
1550− return $ D.Yield x (ReadUState contents end (PTR_NEXT(cur,a)))
1437+ !x <- liftio $ peekWith contents cur
1438+ return $ D.Yield x (ArrayUnsafe contents (INDEX_NEXT(cur,a)) end)
15511439
1552− extract (ReadUState contents end cur) = return $ Array contents cur end end
1440+ extract = return . fromArrayUnsafe
15531441
15541442-- | Resumable unfold of an array.
15551443--
@@ -1572,16 +1460,14 @@ readRevWith liftio = Unfold step inject
15721460 where
15731461
15741462 inject (Array contents start end _) =
1575− let p = PTR_PREV(end,a)
1576− in return $ ReadUState contents start p
1463+ let p = INDEX_PREV(end,a)
1464+ in return $ ArrayUnsafe contents start p
15771465
15781466 {-# INLINE_LATE step #-}
1579− step (ReadUState contents start p) | p < start = liftio $ do
1580− !_ <- touch contents
1581− return D.Stop
1582− step (ReadUState contents start p) = do
1583− !x <- liftio $ peek p
1584− return $ D.Yield x (ReadUState contents start (PTR_PREV(p,a)))
1467+ step (ArrayUnsafe _ start p) | p < start = return D.Stop
1468+ step (ArrayUnsafe contents start p) = do
1469+ !x <- liftio $ peekWith contents p
1470+ return $ D.Yield x (ArrayUnsafe contents start (INDEX_PREV(p,a)))
15851471
15861472-- | Unfold an array into a stream in reverse order.
15871473--
@@ -1612,8 +1498,7 @@ toListFB c n Array{..} = go arrStart
16121498 -- evaluated/written to before we peek at them.
16131499 -- XXX
16141500 let !x = unsafeInlineIO $ do
1615− r <- peek p
1616− touch arrContents
1501+ r <- peekWith arrContents p
16171502 return r
16181503 in c x (go (PTR_NEXT(p,a)))
16191504-}
@@ -1630,9 +1515,8 @@ toList Array{..} = liftIO $ go arrStart
16301515
16311516 go p | assert (p <= aEnd) (p == aEnd) = return []
16321517 go p = do
1633− x <- peek p
1634− touch arrContents
1635− (:) x <$> go (PTR_NEXT(p,a))
1518+ x <- peekWith arrContents p
1519+ (:) x <$> go (INDEX_NEXT(p,a))
16361520
16371521{-# INLINE_NORMAL toStreamDWith #-}
16381522toStreamDWith ::
@@ -1645,9 +1529,8 @@ toStreamDWith liftio Array{..} = D.Stream step arrStart
16451529 {-# INLINE_LATE step #-}
16461530 step _ p | assert (p <= aEnd) (p == aEnd) = return D.Stop
16471531 step _ p = liftio $ do
1648− r <- peek p
1649− touch arrContents
1650− return $ D.Yield r (PTR_NEXT(p,a))
1532+ r <- peekWith arrContents p
1533+ return $ D.Yield r (INDEX_NEXT(p,a))
16511534
16521535-- | Use the 'read' unfold instead.
16531536--
@@ -1669,10 +1552,9 @@ toStreamKWith liftio Array{..} = go arrStart
16691552 go p | assert (p <= aEnd) (p == aEnd) = K.nil
16701553 | otherwise =
16711554 let elemM = do
1672− r <- peek p
1673− touch arrContents
1555+ r <- peekWith arrContents p
16741556 return r
1675− in liftio elemM `K.consM` go (PTR_NEXT(p,a))
1557+ in liftio elemM `K.consM` go (INDEX_NEXT(p,a))
16761558
16771559{-# INLINE toStreamK #-}
16781560toStreamK :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a
@@ -1683,7 +1565,7 @@ toStreamDRevWith ::
16831565 forall m a. (Monad m, Storable a)
16841566 => (forall b. IO b -> m b) -> Array a -> D.Stream m a
16851567toStreamDRevWith liftio Array{..} =
1686− let p = PTR_PREV(aEnd,a)
1568+ let p = INDEX_PREV(aEnd,a)
16871569 in D.Stream step p
16881570
16891571 where
@@ -1691,9 +1573,8 @@ toStreamDRevWith liftio Array{..} =
16911573 {-# INLINE_LATE step #-}
16921574 step _ p | p < arrStart = return D.Stop
16931575 step _ p = liftio $ do
1694− r <- peek p
1695− touch arrContents
1696− return $ D.Yield r (PTR_PREV(p,a))
1576+ r <- peekWith arrContents p
1577+ return $ D.Yield r (INDEX_PREV(p,a))
16971578
16981579-- | Use the 'readRev' unfold instead.
16991580--
@@ -1709,7 +1590,7 @@ toStreamKRevWith ::
17091590 forall m a. (Monad m, Storable a)
17101591 => (forall b. IO b -> m b) -> Array a -> K.Stream m a
17111592toStreamKRevWith liftio Array {..} =
1712− let p = PTR_PREV(aEnd,a)
1593+ let p = INDEX_PREV(aEnd,a)
17131594 in go p
17141595
17151596 where
@@ -1717,10 +1598,9 @@ toStreamKRevWith liftio Array {..} =
17171598 go p | p < arrStart = K.nil
17181599 | otherwise =
17191600 let elemM = do
1720− r <- peek p
1721− touch arrContents
1601+ r <- peekWith arrContents p
17221602 return r
1723− in liftio elemM `K.consM` go (PTR_PREV(p,a))
1603+ in liftio elemM `K.consM` go (INDEX_PREV(p,a))
17241604
17251605{-# INLINE toStreamKRev #-}
17261606toStreamKRev :: 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
17471627-- Folds
17481628-------------------------------------------------------------------------------
17491629
1750−data ArrayUnsafe a = ArrayUnsafe
1751− UNPACKIF !ArrayContents -- contents
1752− {-# UNPACK #-} !(Ptr a) -- start address
1753− {-# UNPACK #-} !(Ptr a) -- first unused address
1754−
1755−toArrayUnsafe :: Array a -> ArrayUnsafe a
1756−toArrayUnsafe (Array contents start end _) =
1757− ArrayUnsafe contents start end
1758−
1759−fromArrayUnsafe ::
1760−#ifdef DEVBUILD
1761− Storable a =>
1762−#endif
1763− ArrayUnsafe a -> Array a
1764−fromArrayUnsafe (ArrayUnsafe contents start end) =
1765− Array contents start end end
1766−
17671630-- Note: Arrays may be allocated with a specific alignment at the beginning of
17681631-- the array. If you need to maintain that alignment on reallocations then you
17691632-- can resize the array manually before append, using an aligned resize
@@ -1771,7 +1634,8 @@ fromArrayUnsafe (ArrayUnsafe contents start end) =
17711634
17721635-- XXX Keep the bound intact to not lose any free space? Perf impact?
17731636
1774−-- | Append up to @n@ input items to the supplied array.
1637+-- | @appendNUnsafe alloc n@ appends up to @n@ input items to the supplied
1638+-- array.
17751639--
17761640-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory
17771641-- corruption or segfault.
@@ -1792,7 +1656,7 @@ appendNUnsafe action n =
17921656 initial = do
17931657 assert (n >= 0) (return ())
17941658 arr@(Array _ _ end bound) <- action
1795− let free = bound `minusPtr` end
1659+ let free = bound - end
17961660 needed = n * SIZE_OF(a)
17971661 -- XXX We can also reallocate if the array has too much free space,
17981662 -- otherwise we lose that space.
@@ -1803,8 +1667,8 @@ appendNUnsafe action n =
18031667 return $ toArrayUnsafe arr1
18041668
18051669 step (ArrayUnsafe contents start end) x = do
1806− liftIO $ poke end x >> touch contents
1807− return $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1670+ liftIO $ pokeWith contents end x
1671+ return $ ArrayUnsafe contents start (INDEX_NEXT(end,a))
18081672
18091673-- | Append @n@ elements to an existing array. Any free space left in the array
18101674-- after appending @n@ elements is lost.
@@ -1858,17 +1722,16 @@ append = appendWith (* 2)
18581722{-# INLINE_NORMAL writeNWithUnsafe #-}
18591723writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)
18601724 => (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
18621726
18631727 where
18641728
1865− initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1729+ initial = toArrayUnsafe <$> alloc (max n 0)
18661730
18671731 step (ArrayUnsafe contents start end) x = do
1868− liftIO $ poke end x >> touch contents
1732+ liftIO $ pokeWith contents end x
18691733 return
1870− $ FL.Partial
1871− $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1734+ $ ArrayUnsafe contents start (INDEX_NEXT(end,a))
18721735
18731736-- | Like 'writeN' but does not check the array bounds when writing. The fold
18741737-- driver must not call the step function more than 'n' times otherwise it will
@@ -1913,20 +1776,19 @@ writeN = writeNWith newArray
19131776{-# INLINE_NORMAL writeRevNWithUnsafe #-}
19141777writeRevNWithUnsafe :: forall m a. (MonadIO m, Storable a)
19151778 => (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
19171780
19181781 where
19191782
19201783 toArrayUnsafeRev (Array contents _ _ bound) =
19211784 ArrayUnsafe contents bound bound
19221785
1923− initial = FL.Partial . toArrayUnsafeRev <$> alloc (max n 0)
1786+ initial = toArrayUnsafeRev <$> alloc (max n 0)
19241787
19251788 step (ArrayUnsafe contents start end) x = do
1926− let ptr = PTR_PREV(start,a)
1927− liftIO $ poke ptr x >> touch contents
1789+ let ptr = INDEX_PREV(start,a)
1790+ liftIO $ pokeWith contents ptr x
19281791 return
1929− $ FL.Partial
19301792 $ ArrayUnsafe contents ptr end
19311793
19321794-- | Like writeNWith but writes the array in reverse order.
@@ -1957,23 +1819,6 @@ writeNAligned :: forall m a. (MonadIO m, Storable a)
19571819 => Int -> Int -> Fold m a (Array a)
19581820writeNAligned align = writeNWith (newArrayAligned align)
19591821
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
1964−-- of the program.
1965−--
1966−-- >>> f = Array.newArrayAlignedUnmanaged
1967−-- >>> writeNAlignedUnmanaged a = Array.writeNWith (f a)
1968−-- >>> writeNAlignedUnmanaged a n = Array.appendN (f a n) n
1969−--
1970−-- /Pre-release/
1971−--
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)
1976−
19771822-- XXX Buffer to a list instead?
19781823--
19791824-- | Buffer a stream into a stream of arrays.
@@ -2030,15 +1875,15 @@ writeWith elemCount =
20301875 where
20311876
20321877 insertElem (Array contents start end bound) x = do
2033− liftIO $ poke end x
2034− return $ Array contents start (PTR_NEXT(end,a)) bound
1878+ liftIO $ pokeWith contents end x
1879+ return $ Array contents start (INDEX_NEXT(end,a)) bound
20351880
20361881 initial = do
20371882 when (elemCount < 0) $ error "writeWith: elemCount is negative"
20381883 liftIO $ newArrayAligned (alignment (undefined :: a)) elemCount
20391884 step arr@(Array _ start end bound) x
2040− | PTR_NEXT(end,a) > bound = do
2041− let oldSize = end `minusPtr` start
1885+ | INDEX_NEXT(end,a) > bound = do
1886+ let oldSize = end - start
20421887 newSize = max (oldSize * 2) 1
20431888 arr1 <-
20441889 liftIO
@@ -2077,14 +1922,14 @@ fromStreamDN :: forall m a. (MonadIO m, Storable a)
20771922-- fromStreamDN n = D.fold (writeN n)
20781923fromStreamDN limit str = do
20791924 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
20811926 return $ arr {aEnd = end}
20821927
20831928 where
20841929
2085− fwrite ptr x = do
2086− liftIO $ poke ptr x
2087− return $ PTR_NEXT(ptr,a)
1930+ fwrite arrContents ptr x = do
1931+ liftIO $ pokeWith arrContents ptr x
1932+ return $ INDEX_NEXT(ptr,a)
20881933
20891934-- | Create an 'Array' from the first N elements of a list. The array is
20901935-- allocated to size N, if the list terminates before N elements then the
@@ -2156,45 +2001,60 @@ fromListRev xs = fromListRevN (Prelude.length xs) xs
21562001-- Combining
21572002-------------------------------------------------------------------------------
21582003
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#
2018+ , () #)
2019+
21592020-- | Copy two arrays into a newly allocated array.
21602021{-# INLINE spliceCopy #-}
2161−spliceCopy :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)
2162−spliceCopy arr1 arr2 = do
2163− let src1 = arrStart arr1
2164− src2 = arrStart arr2
2165− len1 = aEnd arr1 `minusPtr` src1
2166− len2 = aEnd arr2 `minusPtr` src2
2167−
2168− arr <- liftIO $ newArray (len1 + len2)
2169− let dst = arrStart arr
2170−
2171− -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to
2172− -- ccall?
2173− liftIO $ do
2174− memcpy (castPtr dst) (castPtr src1) len1
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) }
2022+spliceCopy :: forall m a. (MonadIO m, Storable a) =>
2023+ Array a -> Array a -> m (Array a)
2024+spliceCopy arr1 arr2 = liftIO $ do
2025+ let start1 = arrStart arr1
2026+ start2 = arrStart arr2
2027+ len1 = aEnd arr1 - start1
2028+ len2 = aEnd arr2 - start2
2029+ newArrContents <-
2030+ liftIO
2031+ $ newAlignedArrayContents
2032+ (len1 + len2)
2033+ (alignment (undefined :: a))
2034+ let len = len1 + len2
2035+ newArr = Array newArrContents 0 len len
2036+ putSliceUnsafe arr1 start1 newArr 0 len1
2037+ putSliceUnsafe arr2 start2 newArr len1 len2
2038+ return newArr
21792039
21802040-- | Really really unsafe, appends the second array into the first array. If
21812041-- the first array does not have enough space it may cause silent data
21822042-- corruption or if you are lucky a segfault.
21832043{-# INLINE spliceUnsafe #-}
2184−spliceUnsafe :: MonadIO m => Array a -> (Array a, Int) -> m (Array a)
2185−spliceUnsafe dst (src, srcLen) =
2044+spliceUnsafe :: MonadIO m =>
2045+ Array a -> Array a -> m (Array a)
2046+spliceUnsafe dst src =
21862047 liftIO $ do
2187− let psrc = arrStart src
2188− let pdst = aEnd dst
2189− assert (pdst `plusPtr` srcLen <= aBound dst) (return ())
2190− memcpy (castPtr pdst) (castPtr psrc) srcLen
2191− touch (arrContents src)
2192− touch (arrContents dst)
2193− return $ dst {aEnd = pdst `plusPtr` srcLen}
2048+ let startSrc = arrStart src
2049+ srcLen = aEnd src - startSrc
2050+ endDst = aEnd dst
2051+ assertM (endDst + srcLen <= aBound dst)
2052+ putSliceUnsafe src startSrc dst endDst srcLen
2053+ return $ dst {aEnd = endDst + srcLen}
21942054
21952055-- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no
21962056-- 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
21982058-- first array and @srcBytes@ is the size of the second array, in bytes.
21992059--
22002060-- 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
22092069 in D.fold f (toStreamD src)
22102070-}
22112071 assert (end <= bound) (return ())
2212− let srcLen = aEnd src `minusPtr` arrStart src
2072+ let srcBytes = aEnd src - arrStart src
22132073
22142074 dst1 <-
2215− if end `plusPtr` srcLen >= bound
2075+ if end + srcBytes >= bound
22162076 then do
2217− let oldSize = end `minusPtr` start
2218− newSize = sizer oldSize srcLen
2219− when (newSize < oldSize + srcLen)
2077+ let dstBytes = end - start
2078+ newSizeInBytes = sizer dstBytes srcBytes
2079+ when (newSizeInBytes < dstBytes + srcBytes)
22202080 $ error
22212081 $ "splice: newSize is less than the total size "
22222082 ++ "of arrays being appended. Please check the "
2223− ++ "newSize function passed."
2224− liftIO $ realloc newSize dst
2083+ ++ "sizer function passed."
2084+ liftIO $ realloc newSizeInBytes dst
22252085 else return dst
2226− spliceUnsafe dst1 (src, srcLen)
2086+ spliceUnsafe dst1 src
22272087
22282088-- | The first array is mutated to append the second array. If there is no
22292089-- 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))
22602120{-# INLINE breakOn #-}
22612121breakOn :: MonadIO m
22622122 => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))
2263−breakOn sep arr@Array{..} = liftIO $ do
2264− let p = arrStart
2265− loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)
2123+breakOn sep arr@Array{..} = asPtrUnsafe arr $ \p -> liftIO $ do
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.
2127+ loc <- c_memchr p sep (fromIntegral $ byteLength arr)
2128+ let sepIndex = loc `minusPtr` p
22662129 return $
22672130 if loc == nullPtr
22682131 then (arr, Nothing)
@@ -2270,12 +2133,12 @@ breakOn sep arr@Array{..} = liftIO $ do
22702133 ( Array
22712134 { arrContents = arrContents
22722135 , arrStart = arrStart
2273− , aEnd = loc
2274− , aBound = loc
2136+ , aEnd = arrStart + sepIndex -- exclude the separator
2137+ , aBound = arrStart + sepIndex
22752138 }
22762139 , Just $ Array
22772140 { arrContents = arrContents
2278− , arrStart = arrStart `plusPtr` (loc `minusPtr` p + 1)
2141+ , arrStart = arrStart + (sepIndex + 1)
22792142 , aEnd = aEnd
22802143 , aBound = aBound
22812144 }
@@ -2294,7 +2157,7 @@ splitAt i arr@Array{..} =
22942157 then error $ "sliceAt: specified array index " ++ show i
22952158 ++ " is beyond the maximum index " ++ show maxIndex
22962159 else let off = i * SIZE_OF(a)
2297− p = arrStart `plusPtr` off
2160+ p = arrStart + off
22982161 in ( Array
22992162 { arrContents = arrContents
23002163 , arrStart = arrStart
@@ -2303,7 +2166,7 @@ splitAt i arr@Array{..} =
23032166 }
23042167 , Array
23052168 { arrContents = arrContents
2306− , arrStart = arrStart `plusPtr` off
2169+ , arrStart = p
23072170 , aEnd = aEnd
23082171 , aBound = aBound
23092172 }
@@ -2326,7 +2189,7 @@ castUnsafe ::
23262189#endif
23272190 Array a -> Array b
23282191castUnsafe (Array contents start end bound) =
2329− Array contents (castPtr start) (castPtr end) (castPtr bound)
2192+ Array (castContents contents) start end bound
23302193
23312194-- | Cast an @Array a@ into an @Array Word8@.
23322195--
@@ -2349,44 +2212,82 @@ cast arr =
23492212 then Nothing
23502213 else Just $ castUnsafe arr
23512214
2352−-- | Use an @Array a@ as @Ptr a@.
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.
2219+--
2220+-- From the GHC manual:
2221+--
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.
2226+
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.
2231+
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.
2234+--
2235+-- If the array is not pinned it is copied to pinned memory before passing it
2236+-- to the monadic action.
2237+--
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
2241+-- if possible.
23532242--
23542243-- /Unsafe/
23552244--
23562245-- /Pre-release/
23572246--
23582247asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b
2359−asPtrUnsafe Array{..} f = do
2360− r <- f arrStart
2361− liftIO $ touch arrContents
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.
2255+ r <- f (ptr `plusPtr` arrStart arr)
2256+ liftIO $ touch contents
23622257 return r
23632258
23642259-------------------------------------------------------------------------------
23652260-- Equality
23662261-------------------------------------------------------------------------------
23672262
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
23692265--
23702266-- /Pre-release/
23712267{-# INLINE cmp #-}
2372−cmp :: MonadIO m => Array a -> Array a -> m Bool
2268+cmp :: MonadIO m => Array a -> Array a -> m Ordering
23732269cmp arr1 arr2 =
2374− liftIO $ do
2375− let ptr1 = arrStart arr1
2376− let ptr2 = arrStart arr2
2377− let len1 = aEnd arr1 `minusPtr` ptr1
2378− let len2 = aEnd arr2 `minusPtr` ptr2
2379−
2380− if len1 == len2
2381− then
2382− if ptr1 == ptr2
2383− then return True
2384− else do
2385− r <- memcmp (castPtr ptr1) (castPtr ptr2) len1
2386− touch (arrContents arr1)
2387− touch (arrContents arr2)
2388− return r
2389− else return False
2270+ liftIO
2271+ $ do
2272+ let marr1 = getMutableByteArray# (arrContents arr1)
2273+ marr2 = getMutableByteArray# (arrContents arr2)
2274+ !(I# st1#) = arrStart arr1
2275+ !(I# st2#) = arrStart arr2
2276+ !(I# len#) = byteLength arr1
2277+ case compare (byteLength arr1) (byteLength arr2) of
2278+ EQ -> do
2279+ r <- liftIO $ IO $ \s# ->
2280+ let res =
2281+ I#
2282+ (compareByteArrays#
2283+ (unsafeCoerce# marr1)
2284+ st1#
2285+ (unsafeCoerce# marr2)
2286+ st2#
2287+ len#)
2288+ in (# s#, res #)
2289+ return $ compare r 0
2290+ x -> return x
23902291
23912292-------------------------------------------------------------------------------
23922293-- NFData
@@ -2408,12 +2309,10 @@ instance NFData1 Array where
24082309{-# INLINE strip #-}
24092310strip :: forall a m. (Storable a, MonadIO m) =>
24102311 (a -> Bool) -> Array a -> m (Array a)
2411−strip eq arr@Array{..} = do
2412− st <- liftIO $ getStart arrStart
2413− end <- liftIO $ getLast aEnd st
2414− liftIO $ do
2415− touch arrContents
2416− return arr {arrStart = st, aEnd = end, aBound = end}
2312+strip eq arr@Array{..} = liftIO $ do
2313+ st <- getStart arrStart
2314+ end <- getLast aEnd st
2315+ return arr {arrStart = st, aEnd = end, aBound = end}
24172316
24182317 where
24192318
@@ -2430,17 +2329,17 @@ strip eq arr@Array{..} = do
24302329 getStart cur = do
24312330 if cur < aEnd
24322331 then do
2433− r <- peek cur
2332+ r <- peekWith arrContents cur
24342333 if eq r
2435− then getStart (PTR_NEXT(cur, a))
2334+ then getStart (INDEX_NEXT(cur,a))
24362335 else return cur
24372336 else return cur
24382337
24392338 getLast cur low = do
24402339 if cur > low
24412340 then do
2442− let prev = PTR_PREV(cur,a)
2443− r <- peek prev
2341+ let prev = INDEX_PREV(cur,a)
2342+ r <- peekWith arrContents prev
24442343 if eq r
24452344 then getLast prev low
24462345 else return cur