@@ -382,35 +382,6 @@ data Array a =
382382 , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory
383383 }
384384
385−nil ::
386−#ifdef DEVBUILD
387− Storable a =>
388−#endif
389− Array a
390−nil = Array nilArrayContents nullPtr nullPtr nullPtr
391−
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.
395−--
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
398−-- supported.
399−--
400−-- /Pre-release/
401−--
402−{-# INLINE fromForeignPtrUnsafe #-}
403−fromForeignPtrUnsafe ::
404−#ifdef DEVBUILD
405− Storable a =>
406−#endif
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)
413−
414385-------------------------------------------------------------------------------
415386-- Construction
416387-------------------------------------------------------------------------------
@@ -473,6 +444,35 @@ nilArrayContents :: ArrayContents
473444nilArrayContents =
474445 fst $ unsafePerformIO $ newAlignedArrayContents 0 0
475446
447+nil ::
448+#ifdef DEVBUILD
449+ Storable a =>
450+#endif
451+ Array a
452+nil = Array nilArrayContents nullPtr nullPtr nullPtr
453+
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.
457+--
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
460+-- supported.
461+--
462+-- /Pre-release/
463+--
464+{-# INLINE fromForeignPtrUnsafe #-}
465+fromForeignPtrUnsafe ::
466+#ifdef DEVBUILD
467+ Storable a =>
468+#endif
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)
475+
476476-- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned
477477-- memory. The memory will never be freed by GHC. This could be useful in
478478-- allocate-once global data structures. Use carefully as incorrect use can
@@ -772,6 +772,144 @@ allocBytesToElemCount x bytes =
772772arrayChunkBytes :: Int
773773arrayChunkBytes = 1024
774774
775+-------------------------------------------------------------------------------
776+-- Resizing
777+-------------------------------------------------------------------------------
778+
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)
783+
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.
786+--
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 ())
791+
792+ -- Allocate new array
793+ let newCapMax = roundUpLargeArray newCapacity
794+ (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
795+
796+ -- Copy old data
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
805+ touch arrContents
806+
807+ return $ Array
808+ { arrStart = pNew
809+ , arrContents = contents
810+ , aEnd = pNew `plusPtr` newLen
811+ , aBound = pNew `plusPtr` newCap
812+ }
813+
814+-- | @realloc newCapacity array@ reallocates the array to the specified
815+-- capacity in bytes.
816+--
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).
821+--
822+{-# INLINABLE realloc #-}
823+realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
824+realloc n arr =
825+ liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
826+
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) =>
831+ String
832+ -> (Int -> Int)
833+ -> Int
834+ -> Array a
835+ -> m (Array 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 ())
842+ realloc safeCap arr
843+
844+ where
845+
846+ badSize newSize = concat
847+ [ label
848+ , ": new array size is less than required size "
849+ , show newSize
850+ , ". Please check the sizing function passed."
851+ ]
852+
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.
856+--
857+-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to
858+-- the block size (4K).
859+--
860+-- /Pre-release/
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
867+ if req < len
868+ then return arr
869+ else realloc req arr
870+
871+-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
872+-- it is rounded up to the closest power of 2.
873+--
874+-- /Pre-release/
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)
880+ req1 =
881+ if req > largeObjectThreshold
882+ then roundUpToPower2 req
883+ else req
884+ len = aEnd `minusPtr` arrStart
885+ if req1 < len
886+ then return arr
887+ else realloc req1 arr
888+
889+-- | Resize the allocated memory to drop any reserved free space at the end of
890+-- the array and reallocate it to reduce wastage.
891+--
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
894+-- retained.
895+--
896+-- /Pre-release/
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
911+ else return arr
912+
775913-------------------------------------------------------------------------------
776914-- Snoc
777915-------------------------------------------------------------------------------
@@ -819,32 +957,6 @@ snocMay arr@Array{..} x = liftIO $ do
819957 then Just <$> snocNewEnd newEnd arr x
820958 else return Nothing
821959
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) =>
826− String
827− -> (Int -> Int)
828− -> Int
829− -> Array a
830− -> m (Array 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 ())
837− realloc safeCap arr
838−
839− where
840−
841− badSize newSize = concat
842− [ label
843− , ": new array size is less than required size "
844− , show newSize
845− , ". Please check the sizing function passed."
846− ]
847−
848960-- NOINLINE to move it out of the way and not pollute the instruction cache.
849961{-# NOINLINE snocWithRealloc #-}
850962snocWithRealloc :: forall m a. (MonadIO m, Storable a) =>
@@ -915,117 +1027,6 @@ snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes)
9151027snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)
9161028snoc = snocWith (* 2)
9171029
918−-------------------------------------------------------------------------------
919−-- Resizing
920−-------------------------------------------------------------------------------
921−
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)
925−
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.
928−--
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 ())
933−
934− -- Allocate new array
935− let newCapMax = roundUpLargeArray newCapacity
936− (contents, pNew) <- newAlignedArrayContents newCapMax alignSize
937−
938− -- Copy old data
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
947− touch arrContents
948−
949− return $ Array
950− { arrStart = pNew
951− , arrContents = contents
952− , aEnd = pNew `plusPtr` newLen
953− , aBound = pNew `plusPtr` newCap
954− }
955−
956−-- | @realloc newCapacity array@ reallocates the array to the specified
957−-- capacity in bytes.
958−--
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).
963−--
964−{-# INLINABLE realloc #-}
965−realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)
966−realloc n arr =
967− liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr
968−
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.
972−--
973−-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to
974−-- the block size (4K).
975−--
976−-- /Pre-release/
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
983− if req < len
984− then return arr
985− else realloc req arr
986−
987−-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then
988−-- it is rounded up to the closest power of 2.
989−--
990−-- /Pre-release/
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)
996− req1 =
997− if req > largeObjectThreshold
998− then roundUpToPower2 req
999− else req
1000− len = aEnd `minusPtr` arrStart
1001− if req1 < len
1002− then return arr
1003− else realloc req1 arr
1004−
1005−-- | Resize the allocated memory to drop any reserved free space at the end of
1006−-- the array and reallocate it to reduce wastage.
1007−--
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
1010−-- retained.
1011−--
1012−-- /Pre-release/
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
1027− else return arr
1028−
10291030-------------------------------------------------------------------------------
10301031-- Random reads
10311032-------------------------------------------------------------------------------
@@ -1720,6 +1721,44 @@ append :: forall m a. (MonadIO m, Storable a) =>
17201721 m (Array a) -> Fold m a (Array a)
17211722append = appendWith (* 2)
17221723
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.
1726+--
1727+-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function
1728+-- as argument.
1729+--
1730+-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n
1731+--
1732+-- /Pre-release/
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)
1737+
1738+ where
1739+
1740+ initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1741+
1742+ step (ArrayUnsafe contents start end) x = do
1743+ liftIO $ poke end x >> touch contents
1744+ return
1745+ $ FL.Partial
1746+ $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1747+
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
1752+-- slowdown.
1753+--
1754+-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray
1755+--
1756+-- @since 0.7.0
1757+{-# INLINE_NORMAL writeNUnsafe #-}
1758+writeNUnsafe :: forall m a. (MonadIO m, Storable a)
1759+ => Int -> Fold m a (Array a)
1760+writeNUnsafe = writeNWithUnsafe newArray
1761+
17231762-- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array
17241763-- allocated using the @alloc@ function.
17251764--
@@ -1773,44 +1812,6 @@ writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)
17731812 => Int -> Int -> Fold m a (Array a)
17741813writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align)
17751814
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.
1778−--
1779−-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function
1780−-- as argument.
1781−--
1782−-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n
1783−--
1784−-- /Pre-release/
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)
1789−
1790− where
1791−
1792− initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)
1793−
1794− step (ArrayUnsafe contents start end) x = do
1795− liftIO $ poke end x >> touch contents
1796− return
1797− $ FL.Partial
1798− $ ArrayUnsafe contents start (PTR_NEXT(end,a))
1799−
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
1804−-- slowdown.
1805−--
1806−-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray
1807−--
1808−-- @since 0.7.0
1809−{-# INLINE_NORMAL writeNUnsafe #-}
1810−writeNUnsafe :: forall m a. (MonadIO m, Storable a)
1811− => Int -> Fold m a (Array a)
1812−writeNUnsafe = writeNWithUnsafe newArray
1813−
18141815-- XXX Buffer to a list instead?
18151816--
18161817-- | Buffer a stream into a stream of arrays.