@@ -382,35 +382,6 @@ data Array a =
382 , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory
382 , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory
390−nil = Array nilArrayContents nullPtr nullPtr nullPtr
392−-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts
393−-- at the memory pointed by the @foreignPtr@, @end@ is the first unused
394−-- address, and @bound@ is the first address beyond the allocated memory.
396−-- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an
397−-- integral multiple of the element size. Only PlainPtr type ForeignPtr is
402−{-# INLINE fromForeignPtrUnsafe #-}
403−fromForeignPtrUnsafe ::
407− ForeignPtr a -> Ptr a -> Ptr a -> Array a
408−fromForeignPtrUnsafe (ForeignPtr start _) _ _
409− | Ptr start == nullPtr = nil
410−fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound =
411− assert (unsafeForeignPtrToPtr fp <= end && end <= bound)
412− (Array (fptrToArrayContents contents) (Ptr start) end bound)
414-------------------------------------------------------------------------------
385-------------------------------------------------------------------------------
415-- Construction
386-- Construction
416-------------------------------------------------------------------------------
387-------------------------------------------------------------------------------
@@ -473,6 +444,35 @@ nilArrayContents :: ArrayContents
473nilArrayContents =
444nilArrayContents =
474 fst $ unsafePerformIO $ newAlignedArrayContents 0 0
445 fst $ unsafePerformIO $ newAlignedArrayContents 0 0
452+nil = Array nilArrayContents nullPtr nullPtr nullPtr
454+-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts
455+-- at the memory pointed by the @foreignPtr@, @end@ is the first unused
456+-- address, and @bound@ is the first address beyond the allocated memory.
458+-- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an
459+-- integral multiple of the element size. Only PlainPtr type ForeignPtr is
464+{-# INLINE fromForeignPtrUnsafe #-}
465+fromForeignPtrUnsafe ::
469+ ForeignPtr a -> Ptr a -> Ptr a -> Array a
470+fromForeignPtrUnsafe (ForeignPtr start _) _ _
471+ | Ptr start == nullPtr = nil
472+fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound =
473+ assert (unsafeForeignPtrToPtr fp <= end && end <= bound)
474+ (Array (fptrToArrayContents contents) (Ptr start) end bound)
476-- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned
476-- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned
477-- memory. The memory will never be freed by GHC. This could be useful in
477-- memory. The memory will never be freed by GHC. This could be useful in
478-- allocate-once global data structures. Use carefully as incorrect use can
478-- allocate-once global data structures. Use carefully as incorrect use can
@@ -772,6 +772,144 @@ allocBytesToElemCount x bytes =
772arrayChunkBytes :: Int
772arrayChunkBytes :: Int
773arrayChunkBytes = 1024
773arrayChunkBytes = 1024
775+-------------------------------------------------------------------------------
777+-------------------------------------------------------------------------------
779+-- | Round the second argument down to multiples of the first argument.
780+{-# INLINE roundDownTo #-}
781+roundDownTo :: Int -> Int -> Int
782+roundDownTo elemSize size = size - (size `mod` elemSize)
784+-- XXX See if resizing can be implemented by reading the old array as a stream
785+-- and then using writeN to the new array.
787+{-# NOINLINE reallocAligned #-}
788+reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a)
789+reallocAligned elemSize alignSize newCapacity Array{..} = do
790+ assert (aEnd <= aBound) (return ())
792+ -- Allocate new array
793+ let newCapMax = roundUpLargeArray newCapacity
794+ (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
797+ let oldStart = arrStart
798+ oldSize = aEnd `minusPtr` oldStart
799+ newCap = roundDownTo elemSize newCapMax
800+ newLen = min oldSize newCap
801+ assert (oldSize `mod` elemSize == 0) (return ())
802+ assert (newLen >= 0) (return ())
803+ assert (newLen `mod` elemSize == 0) (return ())
804+ memcpy (castPtr pNew) (castPtr oldStart) newLen
809+ , arrContents = contents
810+ , aEnd = pNew `plusPtr` newLen
811+ , aBound = pNew `plusPtr` newCap
814+-- | @realloc newCapacity array@ reallocates the array to the specified
815+-- capacity in bytes.
817+-- If the new size is less than the original array the array gets truncated.
818+-- If the new size is not a multiple of array element size then it is rounded
819+-- down to multiples of array size. If the new size is more than
820+-- 'largeObjectThreshold' then it is rounded up to the block size (4K).
822+{-# INLINABLE realloc #-}
823+realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
825+ liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
827+-- | @reallocWith label capSizer minIncrement array@. The label is used
828+-- in error messages and the capSizer is used to determine the capacity of the
829+-- new array in bytes given the current byte length of the array.
830+reallocWith :: forall m a. (MonadIO m , Storable a) =>
836+reallocWith label capSizer minIncr arr = do
837+ let oldSize = aEnd arr `minusPtr` arrStart arr
838+ newCap = capSizer oldSize
839+ newSize = oldSize + minIncr
840+ safeCap = max newCap newSize
841+ assert (newCap >= newSize || error (badSize newSize)) (return ())
846+ badSize newSize = concat
848+ , ": new array size is less than required size "
850+ , ". Please check the sizing function passed."
853+-- | @resize newCapacity array@ changes the total capacity of the array so that
854+-- it is enough to hold the specified number of elements. Nothing is done if
855+-- the specified capacity is less than the length of the array.
857+-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to
858+-- the block size (4K).
861+{-# INLINE resize #-}
862+resize :: forall m a. (MonadIO m, Storable a) =>
863+ Int -> Array a -> m (Array a)
864+resize n arr@Array{..} = do
865+ let req = SIZE_OF(a) * n
866+ len = aEnd `minusPtr` arrStart
869+ else realloc req arr
871+-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
872+-- it is rounded up to the closest power of 2.
875+{-# INLINE resizeExp #-}
876+resizeExp :: forall m a. (MonadIO m, Storable a) =>
877+ Int -> Array a -> m (Array a)
878+resizeExp n arr@Array{..} = do
879+ let req = roundUpLargeArray (SIZE_OF(a) * n)
881+ if req > largeObjectThreshold
882+ then roundUpToPower2 req
884+ len = aEnd `minusPtr` arrStart
887+ else realloc req1 arr
889+-- | Resize the allocated memory to drop any reserved free space at the end of
890+-- the array and reallocate it to reduce wastage.
892+-- Up to 25% wastage is allowed to avoid reallocations. If the capacity is
893+-- more than 'largeObjectThreshold' then free space up to the 'blockSize' is
897+{-# INLINE rightSize #-}
898+rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a)
899+rightSize arr@Array{..} = do
900+ assert (aEnd <= aBound) (return ())
901+ let start = arrStart
902+ len = aEnd `minusPtr` start
903+ capacity = aBound `minusPtr` start
904+ target = roundUpLargeArray len
905+ waste = aBound `minusPtr` aEnd
906+ assert (target >= len) (return ())
907+ assert (len `mod` SIZE_OF(a) == 0) (return ())
908+ -- We trade off some wastage (25%) to avoid reallocations and copying.
909+ if target < capacity && len < 3 * waste
910+ then realloc target arr
775-------------------------------------------------------------------------------
913-------------------------------------------------------------------------------
777-------------------------------------------------------------------------------
915-------------------------------------------------------------------------------
@@ -819,32 +957,6 @@ snocMay arr@Array{..} x = liftIO $ do
819 then Just <$> snocNewEnd newEnd arr x
957 then Just <$> snocNewEnd newEnd arr x
820 else return Nothing
958 else return Nothing
822−-- | @reallocWith label capSizer minIncrement array@. The label is used
823−-- in error messages and the capSizer is used to determine the capacity of the
824−-- new array in bytes given the current byte length of the array.
825−reallocWith :: forall m a. (MonadIO m , Storable a) =>
831−reallocWith label capSizer minIncr arr = do
832− let oldSize = aEnd arr `minusPtr` arrStart arr
833− newCap = capSizer oldSize
834− newSize = oldSize + minIncr
835− safeCap = max newCap newSize
836− assert (newCap >= newSize || error (badSize newSize)) (return ())
841− badSize newSize = concat
843− , ": new array size is less than required size "
845− , ". Please check the sizing function passed."
848-- NOINLINE to move it out of the way and not pollute the instruction cache.
960-- NOINLINE to move it out of the way and not pollute the instruction cache.
849{-# NOINLINE snocWithRealloc #-}
961{-# NOINLINE snocWithRealloc #-}
850snocWithRealloc :: forall m a. (MonadIO m, Storable a) =>
962snocWithRealloc :: forall m a. (MonadIO m, Storable a) =>
@@ -915,117 +1027,6 @@ snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes)
915snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)
1027snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)
916snoc = snocWith (* 2)
1028snoc = snocWith (* 2)
918−-------------------------------------------------------------------------------
920−-------------------------------------------------------------------------------
922−-- | Round the second argument down to multiples of the first argument.
923−roundDownTo :: Int -> Int -> Int
924−roundDownTo elemSize size = size - (size `mod` elemSize)
926−-- XXX See if resizing can be implemented by reading the old array as a stream
927−-- and then using writeN to the new array.
929−{-# NOINLINE reallocAligned #-}
930−reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a)
931−reallocAligned elemSize alignSize newCapacity Array{..} = do
932− assert (aEnd <= aBound) (return ())
934− -- Allocate new array
935− let newCapMax = roundUpLargeArray newCapacity
936− (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
939− let oldStart = arrStart
940− oldSize = aEnd `minusPtr` oldStart
941− newCap = roundDownTo elemSize newCapMax
942− newLen = min oldSize newCap
943− assert (oldSize `mod` elemSize == 0) (return ())
944− assert (newLen >= 0) (return ())
945− assert (newLen `mod` elemSize == 0) (return ())
946− memcpy (castPtr pNew) (castPtr oldStart) newLen
951− , arrContents = contents
952− , aEnd = pNew `plusPtr` newLen
953− , aBound = pNew `plusPtr` newCap
956−-- | @realloc newCapacity array@ reallocates the array to the specified
957−-- capacity in bytes.
959−-- If the new size is less than the original array the array gets truncated.
960−-- If the new size is not a multiple of array element size then it is rounded
961−-- down to multiples of array size. If the new size is more than
962−-- 'largeObjectThreshold' then it is rounded up to the block size (4K).
964−{-# INLINABLE realloc #-}
965−realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
967− liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
969−-- | @resize newCapacity array@ changes the total capacity of the array so that
970−-- it is enough to hold the specified number of elements. Nothing is done if
971−-- the specified capacity is less than the length of the array.
973−-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to
974−-- the block size (4K).
977−{-# INLINE resize #-}
978−resize :: forall m a. (MonadIO m, Storable a) =>
979− Int -> Array a -> m (Array a)
980−resize n arr@Array{..} = do
981− let req = SIZE_OF(a) * n
982− len = aEnd `minusPtr` arrStart
985− else realloc req arr
987−-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
988−-- it is rounded up to the closest power of 2.
991−{-# INLINE resizeExp #-}
992−resizeExp :: forall m a. (MonadIO m, Storable a) =>
993− Int -> Array a -> m (Array a)
994−resizeExp n arr@Array{..} = do
995− let req = roundUpLargeArray (SIZE_OF(a) * n)
997− if req > largeObjectThreshold
998− then roundUpToPower2 req
1000− len = aEnd `minusPtr` arrStart
1003− else realloc req1 arr
1005−-- | Resize the allocated memory to drop any reserved free space at the end of
1006−-- the array and reallocate it to reduce wastage.
1008−-- Up to 25% wastage is allowed to avoid reallocations. If the capacity is
1009−-- more than 'largeObjectThreshold' then free space up to the 'blockSize' is
1013−{-# INLINE rightSize #-}
1014−rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a)
1015−rightSize arr@Array{..} = do
1016− assert (aEnd <= aBound) (return ())
1017− let start = arrStart
1018− len = aEnd `minusPtr` start
1019− capacity = aBound `minusPtr` start
1020− target = roundUpLargeArray len
1021− waste = aBound `minusPtr` aEnd
1022− assert (target >= len) (return ())
1023− assert (len `mod` SIZE_OF(a) == 0) (return ())
1024− -- We trade off some wastage (25%) to avoid reallocations and copying.
1025− if target < capacity && len < 3 * waste
1026− then realloc target arr
1029-------------------------------------------------------------------------------
1030-------------------------------------------------------------------------------
1030-- Random reads
1031-- Random reads
1031-------------------------------------------------------------------------------
1032-------------------------------------------------------------------------------
@@ -1720,6 +1721,44 @@ append :: forall m a. (MonadIO m, Storable a) =>
1720 m (Array a) -> Fold m a (Array a)
1721 m (Array a) -> Fold m a (Array a)
1721append = appendWith (* 2)
1722append = appendWith (* 2)
1724+-- XXX We can carry bound as well in the state to make sure we do not lose the
1725+-- remaining capacity. Need to check perf impact.
1727+-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function
1730+-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n
1733+{-# INLINE_NORMAL writeNWithUnsafe #-}
1734+writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1735+ => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1736+writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe)
1740+ initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1742+ step (ArrayUnsafe contents start end) x = do
1743+ liftIO $ poke end x >> touch contents
1746+ $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1748+-- | Like 'writeN' but does not check the array bounds when writing. The fold
1749+-- driver must not call the step function more than 'n' times otherwise it will
1750+-- corrupt the memory and crash. This function exists mainly because any
1751+-- conditional in the step function blocks fusion causing 10x performance
1754+-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray
1757+{-# INLINE_NORMAL writeNUnsafe #-}
1758+writeNUnsafe :: forall m a. (MonadIO m, Storable a)
1759+ => Int -> Fold m a (Array a)
1760+writeNUnsafe = writeNWithUnsafe newArray
1723-- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array
1762-- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array
1724-- allocated using the @alloc@ function.
1763-- allocated using the @alloc@ function.
@@ -1773,44 +1812,6 @@ writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)
1773 => Int -> Int -> Fold m a (Array a)
1812 => Int -> Int -> Fold m a (Array a)
1774writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align)
1813writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align)
1776−-- XXX We can carry bound as well in the state to make sure we do not lose the
1777−-- remaining capacity. Need to check perf impact.
1779−-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function
1782−-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n
1785−{-# INLINE_NORMAL writeNWithUnsafe #-}
1786−writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)
1787− => (Int -> m (Array a)) -> Int -> Fold m a (Array a)
1788−writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe)
1792− initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1794− step (ArrayUnsafe contents start end) x = do
1795− liftIO $ poke end x >> touch contents
1798− $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1800−-- | Like 'writeN' but does not check the array bounds when writing. The fold
1801−-- driver must not call the step function more than 'n' times otherwise it will
1802−-- corrupt the memory and crash. This function exists mainly because any
1803−-- conditional in the step function blocks fusion causing 10x performance
1806−-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray
1809−{-# INLINE_NORMAL writeNUnsafe #-}
1810−writeNUnsafe :: forall m a. (MonadIO m, Storable a)
1811− => Int -> Fold m a (Array a)
1812−writeNUnsafe = writeNWithUnsafe newArray
1814-- XXX Buffer to a list instead?
1815-- XXX Buffer to a list instead?
1816-- | Buffer a stream into a stream of arrays.
1817-- | Buffer a stream into a stream of arrays.