@@ -43,6 +43,7 @@ module Streamly.Internal.Data.Array.Foreign.Mut.Type
4343 , putIndexUnsafe
4444 , snocUnsafe
4545 , snoc
46+ , snocLinear
4647
4748 -- * Casting
4849 , cast
@@ -108,6 +109,7 @@ import Control.Exception (assert)
108109import Control.DeepSeq (NFData(..))
109110import Control.Monad (when, void)
110111import Control.Monad.IO.Class (MonadIO(..))
112+import Data.Bits ((.&.))
111113import Data.Functor.Identity (runIdentity)
112114#if __GLASGOW_HASKELL__ < 808
113115import Data.Semigroup (Semigroup(..))
@@ -331,6 +333,49 @@ putIndexUnsafe Array{..} i x =
331333 assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ())
332334 liftIO $ poke elemPtr x
333335
336+-------------------------------------------------------------------------------
337+-- Rounding
338+-------------------------------------------------------------------------------
339+
340+-- XXX Should we use bitshifts in calculations or it gets optimized by the
341+-- compiler/processor itself?
342+--
343+-- | The page or block size used by the GHC allocator. Allocator allocates at
344+-- least a block and then allocates smaller allocations from within a block.
345+blockSize :: Int
346+blockSize = 4 * 1024
347+
348+-- | Allocations larger than 'largeObjectThreshold' are in multiples of block
349+-- size and are always pinned. The space beyond the end of a large object up to
350+-- the end of the block is unused.
351+largeObjectThreshold :: Int
352+largeObjectThreshold = (blockSize * 8) `div` 10
353+
354+-- | Round up an array larger than 'largeObjectThreshold' to use the whole
355+-- block.
356+{-# INLINE roundUpLargeArray #-}
357+roundUpLargeArray :: Int -> Int
358+roundUpLargeArray size =
359+ if size >= largeObjectThreshold
360+ then
361+ assert
362+ (blockSize /= 0 && ((blockSize .&. (blockSize - 1)) == 0))
363+ ((size + blockSize - 1) .&. negate blockSize)
364+ else size
365+
366+{-
367+roundUpToPower2 :: Int -> Int
368+roundUpToPower2 = undefined
369+-}
370+
371+-- XXX remove mkChunkSize, it is not required.
372+-- | The default chunk size by which the array creation routines increase the
373+-- size of the array when the array is grown linearly.
374+--
375+{-# INLINE arrayChunkSize #-}
376+arrayChunkSize :: Int
377+arrayChunkSize = mkChunkSize 1024
378+
334379-------------------------------------------------------------------------------
335380-- Snoc
336381-------------------------------------------------------------------------------
@@ -357,32 +402,102 @@ snocUnsafe :: forall m a. (MonadIO m, Storable a) =>
357402snocUnsafe arr@Array{..} =
358403 snocNewEnd (aEnd `plusPtr` sizeOf (undefined :: a)) arr
359404
405+reallocWith :: forall m a. (MonadIO m , Storable a) =>
406+ String
407+ -> (Int -> Int)
408+ -> Int
409+ -> Array a
410+ -> m (Array a)
411+reallocWith label allocSize reqSize arr = do
412+ let oldSize = aEnd arr `minusPtr` unsafeForeignPtrToPtr (aStart arr)
413+ newSize = allocSize oldSize
414+ safeSize = max newSize (oldSize + reqSize)
415+ rounded = roundUpLargeArray safeSize
416+ assert (newSize >= oldSize + reqSize || error badSize) (return ())
417+ assert (rounded >= safeSize) (return ())
418+ realloc rounded arr
419+
420+ where
421+
422+ badSize = concat
423+ [ label
424+ , ": new array size is less than required size "
425+ , show reqSize
426+ , ". Please check the sizing function passed."
427+ ]
428+
429+-- NOINLINE to move it out of the way and not pollute the instruction cache.
430+{-# NOINLINE snocWithRealloc #-}
431+snocWithRealloc :: forall m a. (MonadIO m, Storable a) =>
432+ (Int -> Int)
433+ -> Array a
434+ -> a
435+ -> m (Array a)
436+snocWithRealloc allocSize arr x = do
437+ let elemSize = sizeOf (undefined :: a)
438+ arr1 <- liftIO $ reallocWith "snocWith" allocSize elemSize arr
439+ snocUnsafe arr1 x
440+
441+-- | @snocWith newSize arr elem@ mutates @arr@ to append @elem@, the length of
442+-- the array increases by 1.
443+--
444+-- If there is no reserved space available in @arr@ it is reallocated to a size
445+-- in bytes determined by the @newSize oldSize@ function, where @oldSize@ is
446+-- the original size of the array in bytes.
447+--
448+-- If the new array size is more than 'largeObjectThreshold' we automatically
449+-- round it up to 'blockSize'.
450+--
451+-- Note that the returned array may be a mutated version of the original array.
452+--
453+-- /Pre-release/
454+{-# INLINE snocWith #-}
455+snocWith :: forall m a. (MonadIO m, Storable a) =>
456+ (Int -> Int)
457+ -> Array a
458+ -> a
459+ -> m (Array a)
460+snocWith allocSize arr x = liftIO $ do
461+ let newEnd = aEnd arr `plusPtr` sizeOf (undefined :: a)
462+ if newEnd <= aBound arr
463+ then snocNewEnd newEnd arr x
464+ else snocWithRealloc allocSize arr x
465+
466+-- | The array is mutated to append an additional element to it. If there
467+-- is no reserved space available in the array then it is reallocated to grow
468+-- it by 'arrayChunkSize' rounded up to 'blockSize' when the size becomes more
469+-- than 'largeObjectThreshold'.
470+--
471+-- Note that the returned array may be a mutated version of the original array.
472+--
473+-- >>> snocLinear = snocWith (+ arrayChunkSize)
474+--
475+-- Performs O(n^2) copies to grow but is thrifty on memory.
476+--
477+-- /Pre-release/
478+{-# INLINE snocLinear #-}
479+snocLinear :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)
480+snocLinear = snocWith (+ arrayChunkSize)
481+
482+-- XXX round it to next power of 2.
483+--
484+-- | The array is mutated to append an additional element to it. If there is no
485+-- reserved space available in the array then it is reallocated to double the
486+-- original size.
487+--
488+-- This is useful to reduce allocations when appending unknown number of
489+-- elements.
490+--
491+-- Note that the returned array may be a mutated version of the original array.
492+--
493+-- >>> snoc = snocWith (* 2)
494+--
495+-- Performs O(n * log n) copies to grow, but is liberal with memory allocation.
496+--
497+-- /Pre-release/
360498{-# INLINE snoc #-}
361499snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)
362−snoc arr@Array {..} x =
363− if aEnd == aBound
364− then do
365− let oldStart = unsafeForeignPtrToPtr aStart
366− size = aEnd `minusPtr` oldStart
367− newSize = size + sizeOf (undefined :: a)
368− newPtr <- liftIO $
369− Malloc.mallocForeignPtrAlignedBytes
370− newSize
371− (alignment (undefined :: a))
372− unsafeWithForeignPtrM newPtr $ \pNew -> liftIO $ do
373− memcpy (castPtr pNew) (castPtr oldStart) size
374− poke (pNew `plusPtr` size) x
375− touchForeignPtr aStart
376− return $
377− Array
378− { aStart = newPtr
379− , aEnd = pNew `plusPtr` (size + sizeOf (undefined :: a))
380− , aBound = pNew `plusPtr` newSize
381− }
382− else liftIO $ do
383− poke aEnd x
384− touchForeignPtr aStart
385− return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)}
500+snoc = snocWith (* 2)
386501
387502-------------------------------------------------------------------------------
388503-- Resizing