Initial commit

bundled/Basement/Block/Base.hs

@@ -0,0 +1,493 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Basement.Block.Base
+    ( Block(..)
+    , MutableBlock(..)
+    -- * Basic accessor
+    , unsafeNew
+    , unsafeThaw
+    , unsafeFreeze
+    , unsafeShrink
+    , unsafeCopyElements
+    , unsafeCopyElementsRO
+    , unsafeCopyBytes
+    , unsafeCopyBytesRO
+    , unsafeCopyBytesPtr
+    , unsafeRead
+    , unsafeWrite
+    , unsafeIndex
+    -- * Properties
+    , length
+    , lengthBytes
+    , isPinned
+    , isMutablePinned
+    , mutableLength
+    , mutableLengthBytes
+    -- * Other methods
+    , empty
+    , mutableEmpty
+    , new
+    , newPinned
+    , withPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , mutableWithPtr
+    , unsafeRecast
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.ST
+import           GHC.IO
+import qualified Data.List
+import           Basement.Compat.Base
+import           Data.Proxy
+import           Basement.Compat.Primitive
+import           Basement.Compat.Semigroup
+import           Basement.Bindings.Memory (sysHsMemcmpBaBa)
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.NormalForm
+import           Basement.Numerical.Additive
+import           Basement.PrimType
+
+-- | A block of memory containing unpacked bytes representing values of type 'ty'
+data Block ty = Block ByteArray#
+    deriving (Typeable)
+
+unsafeBlockPtr :: Block ty -> Ptr ty
+unsafeBlockPtr (Block arrBa) = Ptr (byteArrayContents# arrBa)
+{-# INLINE unsafeBlockPtr #-}
+
+instance Data ty => Data (Block ty) where
+    dataTypeOf _ = blockType
+    toConstr _   = error "toConstr"
+    gunfold _ _  = error "gunfold"
+
+blockType :: DataType
+blockType = mkNoRepType "Basement.Block"
+
+instance NormalForm (Block ty) where
+    toNormalForm (Block !_) = ()
+instance (PrimType ty, Show ty) => Show (Block ty) where
+    show v = show (toList v)
+instance (PrimType ty, Eq ty) => Eq (Block ty) where
+    {-# SPECIALIZE instance Eq (Block Word8) #-}
+    (==) = equal
+instance (PrimType ty, Ord ty) => Ord (Block ty) where
+    compare = internalCompare
+
+instance PrimType ty => Semigroup (Block ty) where
+    (<>) = append
+instance PrimType ty => Monoid (Block ty) where
+    mempty  = empty
+    mconcat = concat
+
+instance PrimType ty => IsList (Block ty) where
+    type Item (Block ty) = ty
+    fromList = internalFromList
+    toList = internalToList
+
+-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'
+data MutableBlock ty st = MutableBlock (MutableByteArray# st)
+
+isPinned :: Block ty -> PinnedStatus
+isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)
+
+isMutablePinned :: MutableBlock s ty -> PinnedStatus
+isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)
+
+length :: forall ty . PrimType ty => Block ty -> CountOf ty
+length (Block ba) =
+    case primShiftToBytes (Proxy :: Proxy ty) of
+        0           -> CountOf (I# (sizeofByteArray# ba))
+        (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits))
+{-# INLINE[1] length #-}
+{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-}
+
+lengthBytes :: Block ty -> CountOf Word8
+lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba))
+{-# INLINE[1] lengthBytes #-}
+
+-- | Return the length of a Mutable Block
+--
+-- note: we don't allow resizing yet, so this can remain a pure function
+mutableLength :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty
+mutableLength mb = sizeRecast $ mutableLengthBytes mb
+{-# INLINE[1] mutableLength #-}
+
+mutableLengthBytes :: MutableBlock ty st -> CountOf Word8
+mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba))
+{-# INLINE[1] mutableLengthBytes #-}
+
+-- | Create an empty block of memory
+empty :: Block ty
+empty = Block ba where !(Block ba) = empty_
+
+empty_ :: Block ()
+empty_ = runST $ primitive $ \s1 ->
+    case newByteArray# 0# s1           of { (# s2, mba #) ->
+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->
+        (# s3, Block ba #) }}
+
+mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim))
+mutableEmpty = primitive $ \s1 ->
+    case newByteArray# 0# s1 of { (# s2, mba #) ->
+        (# s2, MutableBlock mba #) }
+
+-- | Return the element at a specific index from an array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'index' if unsure.
+unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty
+unsafeIndex (Block ba) n = primBaIndex ba n
+{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-}
+{-# INLINE unsafeIndex #-}
+
+-- | make a block from a list of elements.
+internalFromList :: PrimType ty => [ty] -> Block ty
+internalFromList l = runST $ do
+    ma <- new (CountOf len)
+    iter azero l $ \i x -> unsafeWrite ma i x
+    unsafeFreeze ma
+  where
+    !len = Data.List.length l
+
+    iter _  []     _ = return ()
+    iter !i (x:xs) z = z i x >> iter (i+1) xs z
+
+-- | transform a block to a list.
+internalToList :: forall ty . PrimType ty => Block ty -> [ty]
+internalToList blk@(Block ba)
+    | len == azero = []
+    | otherwise    = loop azero
+  where
+    !len = length blk
+    loop !i | i .==# len = []
+            | otherwise  = primBaIndex ba i : loop (i+1)
+
+-- | Check if two blocks are identical
+equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool
+equal a b
+    | la /= lb  = False
+    | otherwise = loop azero
+  where
+    !la = lengthBytes a
+    !lb = lengthBytes b
+    lat = length a
+
+    loop !n | n .==# lat = True
+            | otherwise  = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1)
+    o1 = Offset (I# 1#)
+{-# RULES "Block/Eq/Word8" [3]
+   forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-}
+{-# INLINEABLE [2] equal #-}
+-- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-}
+
+equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool
+equalMemcmp b1@(Block a) b2@(Block b)
+    | la /= lb  = False
+    | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0
+  where
+    la = lengthBytes b1
+    lb = lengthBytes b2
+{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-}
+
+-- | Compare 2 blocks
+internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering
+internalCompare a b = loop azero
+  where
+    !la = length a
+    !lb = length b
+    !end = sizeAsOffset (min la lb)
+    loop !n
+        | n == end  = la `compare` lb
+        | v1 == v2  = loop (n + Offset (I# 1#))
+        | otherwise = v1 `compare` v2
+      where
+        v1 = unsafeIndex a n
+        v2 = unsafeIndex b n
+{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-}
+{-# NOINLINE internalCompare #-}
+
+compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering
+compareMemcmp b1@(Block a) b2@(Block b) =
+    case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of
+        0             -> la `compare` lb
+        n | n > 0     -> GT
+          | otherwise -> LT
+  where
+    la = lengthBytes b1
+    lb = lengthBytes b2
+    sz = min la lb
+{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-}
+
+-- | Append 2 blocks together by creating a new bigger block
+append :: Block ty -> Block ty -> Block ty
+append a b
+    | la == azero = b
+    | lb == azero = a
+    | otherwise = runST $ do
+        r  <- unsafeNew Unpinned (la+lb)
+        unsafeCopyBytesRO r 0                 a 0 la
+        unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb
+        unsafeFreeze r
+  where
+    !la = lengthBytes a
+    !lb = lengthBytes b
+
+concat :: forall ty . [Block ty] -> Block ty
+concat original = runST $ do
+    r <- unsafeNew Unpinned total
+    goCopy r zero original
+    unsafeFreeze r
+  where
+    !total = size 0 original
+    -- size
+    size !sz []     = sz
+    size !sz (x:xs) = size (lengthBytes x + sz) xs
+
+    zero = Offset 0
+
+    goCopy r = loop
+      where
+        loop _  []      = pure ()
+        loop !i (x:xs) = do
+            unsafeCopyBytesRO r i x zero lx
+            loop (i `offsetPlusE` lx) xs
+          where !lx = lengthBytes x
+
+-- | Freeze a mutable block into a block.
+--
+-- If the mutable block is still use after freeze,
+-- then the modification will be reflected in an unexpected
+-- way in the Block.
+unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty)
+unsafeFreeze (MutableBlock mba) = primitive $ \s1 ->
+    case unsafeFreezeByteArray# mba s1 of
+        (# s2, ba #) -> (# s2, Block ba #)
+{-# INLINE unsafeFreeze #-}
+
+unsafeShrink :: PrimMonad prim => MutableBlock ty (PrimState prim) -> CountOf ty -> prim (MutableBlock ty (PrimState prim))
+unsafeShrink (MutableBlock mba) (CountOf (I# nsz)) = primitive $ \s ->
+    case shrinkMutableByteArray# mba nsz s of
+        s -> (# s, MutableBlock mba #)
+
+-- | Thaw an immutable block.
+--
+-- If the immutable block is modified, then the original immutable block will
+-- be modified too, but lead to unexpected results when querying
+unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim))
+unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #)
+
+-- | Create a new mutable block of a specific size in bytes.
+--
+-- Note that no checks are made to see if the size in bytes is compatible with the size
+-- of the underlaying element 'ty' in the block.
+--
+-- use 'new' if unsure
+unsafeNew :: PrimMonad prim
+          => PinnedStatus
+          -> CountOf Word8
+          -> prim (MutableBlock ty (PrimState prim))
+unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of
+    Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }
+    _        -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }
+
+-- | Create a new unpinned mutable block of a specific N size of 'ty' elements
+--
+-- If the size exceeds a GHC-defined threshold, then the memory will be
+-- pinned. To be certain about pinning status with small size, use 'newPinned'
+new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))
+new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)
+
+-- | Create a new pinned mutable block of a specific N size of 'ty' elements
+newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))
+newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)
+
+-- | Copy a number of elements from an array to another array with offsets
+unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)
+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                   -> Offset ty                        -- ^ offset at destination
+                   -> MutableBlock ty (PrimState prim) -- ^ source mutable block
+                   -> Offset ty                        -- ^ offset at source
+                   -> CountOf ty                          -- ^ number of elements to copy
+                   -> prim ()
+unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n =
+    unsafeCopyBytes dstMb (offsetOfE sz destOffset)
+                    srcMb (offsetOfE sz srcOffset)
+                    (sizeOfE sz n)
+  where
+    !sz = primSizeInBytes (Proxy :: Proxy ty)
+
+unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty)
+                     => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                     -> Offset ty                        -- ^ offset at destination
+                     -> Block ty                         -- ^ source block
+                     -> Offset ty                        -- ^ offset at source
+                     -> CountOf ty                          -- ^ number of elements to copy
+                     -> prim ()
+unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n =
+    unsafeCopyBytesRO dstMb (offsetOfE sz destOffset)
+                      srcMb (offsetOfE sz srcOffset)
+                      (sizeOfE sz n)
+  where
+    !sz = primSizeInBytes (Proxy :: Proxy ty)
+
+-- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets
+unsafeCopyBytes :: forall prim ty . PrimMonad prim
+                => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                -> Offset Word8                     -- ^ offset at destination
+                -> MutableBlock ty (PrimState prim) -- ^ source mutable block
+                -> Offset Word8                     -- ^ offset at source
+                -> CountOf Word8                       -- ^ number of elements to copy
+                -> prim ()
+unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) =
+    primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #)
+{-# INLINE unsafeCopyBytes #-}
+
+-- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets
+unsafeCopyBytesRO :: forall prim ty . PrimMonad prim
+                  => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                  -> Offset Word8                     -- ^ offset at destination
+                  -> Block ty                         -- ^ source block
+                  -> Offset Word8                     -- ^ offset at source
+                  -> CountOf Word8                       -- ^ number of elements to copy
+                  -> prim ()
+unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) =
+    primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #)
+{-# INLINE unsafeCopyBytesRO #-}
+
+-- | Copy a number of bytes from a Ptr to a MutableBlock with specific byte offsets
+unsafeCopyBytesPtr :: forall prim ty . PrimMonad prim
+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                   -> Offset Word8                     -- ^ offset at destination
+                   -> Ptr ty                           -- ^ source block
+                   -> CountOf Word8                    -- ^ number of bytes to copy
+                   -> prim ()
+unsafeCopyBytesPtr (MutableBlock dstMba) (Offset (I# d)) (Ptr srcBa) (CountOf (I# n)) =
+    primitive $ \st -> (# copyAddrToByteArray# srcBa dstMba d n st, () #)
+{-# INLINE unsafeCopyBytesPtr #-}
+
+-- | read from a cell in a mutable block without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'read' if unsure.
+unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty
+unsafeRead (MutableBlock mba) i = primMbaRead mba i
+{-# INLINE unsafeRead #-}
+
+-- | write to a cell in a mutable block without bounds checking.
+--
+-- Writing with invalid bounds will corrupt memory and your program will
+-- become unreliable. use 'write' if unsure.
+unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
+unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v
+{-# INLINE unsafeWrite #-}
+
+-- | Get a Ptr pointing to the data in the Block.
+--
+-- Since a Block is immutable, this Ptr shouldn't be
+-- to use to modify the contents
+--
+-- If the Block is pinned, then its address is returned as is,
+-- however if it's unpinned, a pinned copy of the Block is made
+-- before getting the address.
+withPtr :: PrimMonad prim
+        => Block ty
+        -> (Ptr ty -> prim a)
+        -> prim a
+withPtr x@(Block ba) f
+    | isPinned x == Pinned = f (Ptr (byteArrayContents# ba)) <* touch x
+    | otherwise            = do
+        arr <- makeTrampoline
+        f (unsafeBlockPtr arr) <* touch arr
+  where
+    makeTrampoline = do
+        trampoline <- unsafeNew Pinned (lengthBytes x)
+        unsafeCopyBytesRO trampoline 0 x 0 (lengthBytes x)
+        unsafeFreeze trampoline
+
+touch :: PrimMonad prim => Block ty -> prim ()
+touch (Block ba) =
+    unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }
+
+unsafeRecast :: (PrimType t1, PrimType t2)
+             => MutableBlock t1 st
+             -> MutableBlock t2 st
+unsafeRecast (MutableBlock mba) = MutableBlock mba
+
+-- | Use the 'Ptr' to a mutable block in a safer construct
+--
+-- If the block is not pinned, this is a _dangerous_ operation
+mutableWithPtr :: PrimMonad prim
+                => MutableBlock ty (PrimState prim)
+                -> (Ptr ty -> prim a)
+                -> prim a
+mutableWithPtr = withMutablePtr
+{-# DEPRECATED mutableWithPtr "use withMutablePtr" #-}
+
+-- | Create a pointer on the beginning of the MutableBlock
+-- and call a function 'f'.
+--
+-- The mutable block can be mutated by the 'f' function
+-- and the change will be reflected in the mutable block
+--
+-- If the mutable block is unpinned, a trampoline buffer
+-- is created and the data is only copied when 'f' return.
+--
+-- it is all-in-all highly inefficient as this cause 2 copies
+withMutablePtr :: PrimMonad prim
+               => MutableBlock ty (PrimState prim)
+               -> (Ptr ty -> prim a)
+               -> prim a
+withMutablePtr = withMutablePtrHint False False
+
+
+-- | Same as 'withMutablePtr' but allow to specify 2 optimisations
+-- which is only useful when the MutableBlock is unpinned and need
+-- a pinned trampoline to be called safely.
+--
+-- If skipCopy is True, then the first copy which happen before
+-- the call to 'f', is skipped. The Ptr is now effectively
+-- pointing to uninitialized data in a new mutable Block.
+--
+-- If skipCopyBack is True, then the second copy which happen after
+-- the call to 'f', is skipped. Then effectively in the case of a
+-- trampoline being used the memory changed by 'f' will not
+-- be reflected in the original Mutable Block.
+--
+-- If using the wrong parameters, it will lead to difficult to
+-- debug issue of corrupted buffer which only present themselves
+-- with certain Mutable Block that happened to have been allocated
+-- unpinned.
+--
+-- If unsure use 'withMutablePtr', which default to *not* skip
+-- any copy.
+withMutablePtrHint :: forall ty prim a . PrimMonad prim
+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f
+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f
+                   -> MutableBlock ty (PrimState prim)
+                   -> (Ptr ty -> prim a)
+                   -> prim a
+withMutablePtrHint skipCopy skipCopyBack mb f
+    | isMutablePinned mb == Pinned = callWithPtr mb
+    | otherwise                    = do
+        trampoline <- unsafeNew Pinned vecSz
+        unless skipCopy $
+            unsafeCopyBytes trampoline 0 mb 0 vecSz
+        r <- callWithPtr trampoline
+        unless skipCopyBack $
+            unsafeCopyBytes mb 0 trampoline 0 vecSz
+        pure r
+  where
+    vecSz = mutableLengthBytes mb
+    callWithPtr pinnedMb = do
+        b <- unsafeFreeze pinnedMb
+        f (unsafeBlockPtr b) <* touch b

bundled/Basement/Block/Builder.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block.Builder
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Block builder
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Basement.Block.Builder
+    ( Builder
+    , run
+
+    -- * Emit functions
+    , emit
+    , emitPrim
+    , emitString
+    , emitUTF8Char
+
+    -- * unsafe
+    , unsafeRunString
+    ) where
+
+import qualified Basement.Alg.UTF8 as UTF8
+import           Basement.UTF8.Helper          (charToBytes)
+import           Basement.Numerical.Conversion (charToInt)
+import           Basement.Block.Base (Block(..), MutableBlock(..))
+import qualified Basement.Block.Base as B
+import           Basement.Cast
+import           Basement.Compat.Base
+import           Basement.Compat.Semigroup
+import           Basement.Monad
+import           Basement.FinalPtr (FinalPtr, withFinalPtr)
+import           Basement.Numerical.Additive
+import           Basement.String                (String(..))
+import qualified Basement.String as S
+import           Basement.Types.OffsetSize
+import           Basement.PrimType (PrimType(..), primMbaWrite)
+import           Basement.UArray.Base (UArray(..))
+import qualified Basement.UArray.Base as A
+
+import           GHC.ST
+import           Data.Proxy
+
+newtype Action = Action
+    { runAction_ :: forall prim . PrimMonad prim
+                 => MutableBlock Word8 (PrimState prim)
+                 -> Offset Word8
+                 -> prim (Offset Word8)
+    }
+
+data Builder = Builder {-# UNPACK #-} !(CountOf Word8)
+                                      !Action
+
+instance Semigroup Builder where
+    (<>) = append
+    {-# INLINABLE (<>) #-}
+instance Monoid Builder where
+    mempty = empty
+    {-# INLINABLE mempty #-}
+    mconcat = concat
+    {-# INLINABLE mconcat #-}
+
+-- | create an empty builder
+--
+-- this does nothing, build nothing, take no space (in the resulted block)
+empty :: Builder
+empty = Builder 0 (Action $ \_ !off -> pure off)
+{-# INLINE empty #-}
+
+-- | concatenate the 2 given bulider
+append :: Builder -> Builder -> Builder
+append (Builder size1 (Action action1)) (Builder size2 (Action action2)) =
+    Builder size action
+  where
+    action = Action $ \arr off -> do
+      off' <- action1 arr off
+      action2 arr off'
+    size = size1 + size2
+{-# INLINABLE append #-}
+
+-- | concatenate the list of builder
+concat :: [Builder] -> Builder
+concat = loop 0 (Action $ \_ !off -> pure off)
+  where
+    loop !sz acc          []                              = Builder sz acc
+    loop !sz (Action acc) (Builder !s (Action action):xs) =
+       loop (sz + s) (Action $ \arr off -> acc arr off >>= action arr) xs
+{-# INLINABLE concat #-}
+
+-- | run the given builder and return the generated block
+run :: PrimMonad prim => Builder -> prim (Block Word8)
+run (Builder sz action) = do
+    mb <- B.new sz
+    off <- runAction_ action mb 0
+    B.unsafeShrink mb (offsetAsSize off) >>= B.unsafeFreeze
+
+-- | run the given builder and return a UTF8String
+--
+-- this action is unsafe as there is no guarantee upon the validity of the
+-- content of the built block.
+unsafeRunString :: PrimMonad prim => Builder -> prim String
+unsafeRunString b = do
+    str <- run b
+    pure $ String $ A.UArray 0 (B.length str) (A.UArrayBA str)
+
+-- | add a Block in the builder
+emit :: Block a -> Builder
+emit b = Builder size $ Action $ \arr off ->
+    B.unsafeCopyBytesRO arr off b' 0 size *> pure (off + sizeAsOffset size)
+  where
+    b' :: Block Word8
+    b' = cast b
+    size :: CountOf Word8
+    size = B.length b'
+
+emitPrim :: (PrimType ty, ty ~ Word8) => ty -> Builder
+emitPrim a = Builder size $ Action $ \(MutableBlock arr) off ->
+    primMbaWrite arr off a *> pure (off + sizeAsOffset size)
+  where
+    size = getSize Proxy a
+    getSize :: PrimType ty => Proxy ty -> ty -> CountOf Word8
+    getSize p _ = primSizeInBytes p
+
+-- | add a string in the builder
+emitString :: String -> Builder
+emitString (String str) = Builder size $ Action $ \arr off ->
+    A.onBackendPrim (onBA arr off) (onAddr arr off) str *> pure (off + sizeAsOffset size)
+  where
+    size = A.length str
+    onBA :: PrimMonad prim
+         => MutableBlock Word8 (PrimState prim)
+         -> Offset Word8
+         -> Block Word8
+         -> prim ()
+    onBA   arr off ba   = B.unsafeCopyBytesRO arr off ba 0 size
+    onAddr :: PrimMonad prim
+           => MutableBlock Word8 (PrimState prim)
+           -> Offset Word8
+           -> FinalPtr Word8
+           -> prim ()
+    onAddr arr off fptr = withFinalPtr fptr $ \ptr -> B.unsafeCopyBytesPtr arr off ptr size
+
+-- | emit a UTF8 char in the builder
+--
+-- this function may be replaced by `emit :: Encoding -> Char -> Builder`
+emitUTF8Char :: Char -> Builder
+emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off ->
+    UTF8.writeUTF8 block off c

bundled/Basement/Block/Mutable.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block.Mutable
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A block of memory that contains elements of a type,
+-- very similar to an unboxed array but with the key difference:
+--
+-- * It doesn't have slicing capability (no cheap take or drop)
+-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed
+-- * It's unpackable in any constructor
+-- * It uses unpinned memory by default
+--
+-- It should be rarely needed in high level API, but
+-- in lowlevel API or some data structure containing lots
+-- of unboxed array that will benefit from optimisation.
+--
+-- Because it's unpinned, the blocks are compactable / movable,
+-- at the expense of making them less friendly to interop with the C layer
+-- as address.
+--
+-- Note that sadly the bytearray primitive type automatically create
+-- a pinned bytearray if the size is bigger than a certain threshold
+--
+-- GHC Documentation associated:
+--
+-- includes/rts/storage/Block.h
+--   * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))
+--   * BLOCK_SIZE   (1<<BLOCK_SHIFT)
+--
+-- includes/rts/Constant.h
+--   * BLOCK_SHIFT  12
+--
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Basement.Block.Mutable
+    ( Block(..)
+    , MutableBlock(..)
+    , mutableLengthSize
+    , mutableLength
+    , mutableLengthBytes
+    , mutableWithPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , new
+    , newPinned
+    , mutableEmpty
+    , iterSet
+    , read
+    , write
+    , unsafeNew
+    , unsafeWrite
+    , unsafeRead
+    , unsafeFreeze
+    , unsafeThaw
+    , unsafeCopyElements
+    , unsafeCopyElementsRO
+    , unsafeCopyBytes
+    , unsafeCopyBytesRO
+    , unsafeCopyBytesPtr
+    -- * Foreign
+    , copyFromPtr
+    , copyToPtr
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           Basement.Compat.Base
+import           Data.Proxy
+import           Basement.Exception
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.Numerical.Additive
+import           Basement.PrimType
+import           Basement.Block.Base
+
+-- | Set all mutable block element to a value
+iterSet :: (PrimType ty, PrimMonad prim)
+        => (Offset ty -> ty)
+        -> MutableBlock ty (PrimState prim)
+        -> prim ()
+iterSet f ma = loop 0
+  where
+    !sz = mutableLength ma
+    loop i
+        | i .==# sz = pure ()
+        | otherwise = unsafeWrite ma i (f i) >> loop (i+1)
+    {-# INLINE loop #-}
+
+mutableLengthSize :: PrimType ty => MutableBlock ty st -> CountOf ty
+mutableLengthSize = mutableLength
+{-# DEPRECATED mutableLengthSize "use mutableLength" #-}
+
+-- | read a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty
+read array n
+    | isOutOfBound n len = primOutOfBound OOB_Read n len
+    | otherwise          = unsafeRead array n
+  where len = mutableLength array
+{-# INLINE read #-}
+
+-- | Write to a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write array n val
+    | isOutOfBound n len = primOutOfBound OOB_Write n len
+    | otherwise          = unsafeWrite array n val
+  where
+    len = mutableLengthSize array
+{-# INLINE write #-}
+
+-- | Copy from a pointer, @count@ elements, into the Mutable Block at a starting offset @ofs@
+--
+-- if the source pointer is invalid (size or bad allocation), bad things will happen
+--
+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)
+            => Ptr ty                           -- ^ Source Ptr of 'ty' to start of memory
+            -> MutableBlock ty (PrimState prim) -- ^ Destination mutable block
+            -> Offset ty                        -- ^ Start offset in the destination mutable block
+            -> CountOf ty                       -- ^ Number of 'ty' elements
+            -> prim ()
+copyFromPtr src@(Ptr src#) mb@(MutableBlock mba) ofs count
+    | end > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy end arrSz
+    | otherwise                = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)
+  where
+    end = od `offsetPlusE` arrSz
+
+    sz = primSizeInBytes (Proxy :: Proxy ty)
+    !arrSz@(CountOf (I# bytes#)) = sizeOfE sz count
+    !od@(Offset (I# od#)) = offsetOfE sz ofs
+
+-- | Copy all the block content to the memory starting at the destination address
+--
+-- If the destination pointer is invalid (size or bad allocation), bad things will happen
+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)
+          => MutableBlock ty (PrimState prim) -- ^ The source mutable block to copy
+          -> Offset ty                        -- ^ The source offset in the mutable block
+          -> Ptr ty                           -- ^ The destination address where the copy is going to start
+          -> CountOf ty                       -- ^ The number of bytes
+          -> prim ()
+copyToPtr mb@(MutableBlock mba) ofs dst@(Ptr dst#) count
+    | srcEnd > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy srcEnd arrSz
+    | otherwise                = do
+        blk <- unsafeFreeze mb
+        let !(Block ba) = blk
+        primitive $ \s1 -> (# copyByteArrayToAddr# ba os# dst# szBytes# s1, () #)
+  where
+    srcEnd = os `offsetPlusE` arrSz
+    !os@(Offset (I# os#)) = offsetInBytes ofs
+    !arrSz@(CountOf (I# szBytes#)) = mutableLengthBytes mb