module Foundation.Primitive.Block.Base
( Block(..)
, MutableBlock(..)
, unsafeNew
, unsafeThaw
, unsafeFreeze
, unsafeCopyElements
, unsafeCopyElementsRO
, unsafeCopyBytes
, unsafeCopyBytesRO
, unsafeRead
, unsafeWrite
, unsafeIndex
, lengthSize
, lengthBytes
, new
) where
import GHC.Prim
import GHC.Types
import GHC.ST
import qualified Data.List
import Foundation.Internal.Base
import Foundation.Internal.Proxy
import Foundation.Primitive.Types.OffsetSize
import Foundation.Primitive.Monad
import Foundation.Primitive.NormalForm
import Foundation.Numerical
import Foundation.Primitive.Types
data Block ty = Block ByteArray#
deriving (Typeable)
instance Data ty => Data (Block ty) where
dataTypeOf _ = blockType
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
blockType :: DataType
blockType = mkNoRepType "Foundation.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
(==) = equal
instance (PrimType ty, Ord ty) => Ord (Block ty) where
compare = internalCompare
instance PrimType ty => Monoid (Block ty) where
mempty = empty
mappend = append
mconcat = concat
instance PrimType ty => IsList (Block ty) where
type Item (Block ty) = ty
fromList = internalFromList
toList = internalToList
lengthSize :: forall ty . PrimType ty => Block ty -> Size ty
lengthSize (Block ba) =
let !(Size (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)
!elems = quotInt# (sizeofByteArray# ba) szBits
in Size (I# elems)
lengthBytes :: Block ty -> Size Word8
lengthBytes (Block ba) = Size (I# (sizeofByteArray# ba))
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 #) }}
unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty
unsafeIndex (Block ba) n = primBaIndex ba n
internalFromList :: PrimType ty => [ty] -> Block ty
internalFromList l = runST $ do
ma <- new (Size len)
iter 0 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
internalToList :: forall ty . PrimType ty => Block ty -> [ty]
internalToList blk@(Block ba)
| len == 0 = []
| otherwise = loop 0
where
!len = lengthSize blk
loop !i | i .==# len = []
| otherwise = primBaIndex ba i : loop (i+1)
equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool
equal a b
| la /= lb = False
| otherwise = loop 0
where
!la = lengthSize a
!lb = lengthSize b
loop n | n .==# la = True
| otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)
internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering
internalCompare a b = loop 0
where
!la = lengthSize a
!lb = lengthSize b
loop n
| n .==# la = if la == lb then EQ else LT
| n .==# lb = GT
| otherwise =
case unsafeIndex a n `compare` unsafeIndex b n of
EQ -> loop (n+1)
r -> r
append :: Block ty -> Block ty -> Block ty
append a b
| la == 0 = b
| lb == 0 = a
| otherwise = runST $ do
r <- unsafeNew (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 :: [Block ty] -> Block ty
concat [] = empty
concat l =
case filterAndSum 0 [] l of
(_,[]) -> empty
(_,[x]) -> x
(totalLen,chunks) -> runST $ do
r <- unsafeNew totalLen
doCopy r 0 chunks
unsafeFreeze r
where
filterAndSum !totalLen acc [] = (totalLen, Data.List.reverse acc)
filterAndSum !totalLen acc (x:xs)
| len == 0 = filterAndSum totalLen acc xs
| otherwise = filterAndSum (len+totalLen) (x:acc) xs
where len = lengthBytes x
doCopy _ _ [] = return ()
doCopy r i (x:xs) = do
unsafeCopyBytesRO r i x 0 lx
doCopy r (i `offsetPlusE` lx) xs
where !lx = lengthBytes x
data MutableBlock ty st = MutableBlock (MutableByteArray# st)
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 #)
unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim))
unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #)
unsafeNew :: PrimMonad prim => Size Word8 -> prim (MutableBlock ty (PrimState prim))
unsafeNew (Size (I# bytes)) =
primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }
new :: forall prim ty . (PrimMonad prim, PrimType ty) => Size ty -> prim (MutableBlock ty (PrimState prim))
new n = unsafeNew (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)
unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)
=> MutableBlock ty (PrimState prim)
-> Offset ty
-> MutableBlock ty (PrimState prim)
-> Offset ty
-> Size ty
-> prim ()
unsafeCopyElements dstMb destOffset srcMb srcOffset 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)
-> Offset ty
-> Block ty
-> Offset ty
-> Size ty
-> 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)
unsafeCopyBytes :: forall prim ty . PrimMonad prim
=> MutableBlock ty (PrimState prim)
-> Offset Word8
-> MutableBlock ty (PrimState prim)
-> Offset Word8
-> Size Word8
-> prim ()
unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (Size (I# n)) =
primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #)
unsafeCopyBytesRO :: forall prim ty . PrimMonad prim
=> MutableBlock ty (PrimState prim)
-> Offset Word8
-> Block ty
-> Offset Word8
-> Size Word8
-> prim ()
unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (Size (I# n)) =
primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #)
unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty
unsafeRead (MutableBlock mba) i = primMbaRead mba i
unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v