@@ -1,249 +1,250 @@
1−{-# LANGUAGE UnboxedTuples #-}
1+{-# LANGUAGE TemplateHaskell #-}
3+-- This is required as all the instances in this module are orphan instances.
4+{-# OPTIONS_GHC -fno-warn-orphans #-}
4-- Module : Streamly.Internal.Data.MutByteArray
7-- Module : Streamly.Internal.Data.MutByteArray
5-- Copyright : (c) 2023 Composewell Technologies
8-- Copyright : (c) 2023 Composewell Technologies
6-- License : BSD3-3-Clause
9-- License : BSD3-3-Clause
7-- Maintainer : streamly@composewell.com
10-- Maintainer : streamly@composewell.com
8−-- Stability : experimental
9-- Portability : GHC
11-- Portability : GHC
11module Streamly.Internal.Data.MutByteArray
14module Streamly.Internal.Data.MutByteArray
13− -- ** MutByteArray
16+ -- * MutByteArray
14− MutByteArray(..)
17+ module Streamly.Internal.Data.MutByteArray.Type
15− , MutableByteArray
18+ -- * Unbox
16− , getMutableByteArray#
19+ , module Streamly.Internal.Data.Unbox
17−
20+ , module Streamly.Internal.Data.Unbox.TH
18− -- ** Pinning
21+ -- * Serialize
19− , PinnedState(..)
22+ , module Streamly.Internal.Data.Serialize.Type
20− , isPinned
23+ -- * Serialize TH
21− , pin
24+ , module Streamly.Internal.Data.Serialize.TH
29− , pinnedNewAlignedBytes
32− , sizeOfMutableByteArray
37−import Control.Monad.IO.Class (MonadIO(..))
27+--------------------------------------------------------------------------------
38−#ifdef DEBUG
28+-- Imports
39−import Debug.Trace (trace)
29+--------------------------------------------------------------------------------
31+import Data.Proxy (Proxy(..))
32+import Streamly.Internal.Data.Array (Array(..))
33+import GHC.Exts (Int(..), sizeofByteArray#, unsafeCoerce#)
34+import GHC.Word (Word8)
36+#if __GLASGOW_HASKELL__ >= 900
37+import GHC.Num.Integer (Integer(..))
39+import GHC.Integer.GMP.Internals (Integer(..), BigNat(..))
41−import GHC.Base (IO(..))
42−import System.IO.Unsafe (unsafePerformIO)
44−import GHC.Exts
42+import Streamly.Internal.Data.MutByteArray.Type
43+import Streamly.Internal.Data.Serialize.TH
44+import Streamly.Internal.Data.Serialize.Type
45+import Streamly.Internal.Data.Unbox
46+import Streamly.Internal.Data.Unbox.TH
46--------------------------------------------------------------------------------
48--------------------------------------------------------------------------------
47−-- The ArrayContents type
49+-- Common instances
48--------------------------------------------------------------------------------
50--------------------------------------------------------------------------------
50−data PinnedState
52+-- Note
54−-- XXX can use UnliftedNewtypes
56−-- | A lifted mutable byte array type wrapping @MutableByteArray# RealWorld@.
57−-- This is a low level array used to back high level unboxed arrays and
59−data MutByteArray = MutByteArray (MutableByteArray# RealWorld)
61−{-# DEPRECATED MutableByteArray "Please use MutByteArray instead" #-}
62−type MutableByteArray = MutByteArray
64−{-# INLINE getMutableByteArray# #-}
65−getMutableByteArray# :: MutByteArray -> MutableByteArray# RealWorld
66−getMutableByteArray# (MutByteArray mbarr) = mbarr
68−-- | Return the size of the array in bytes.
69−{-# INLINE sizeOfMutableByteArray #-}
70−sizeOfMutableByteArray :: MutByteArray -> IO Int
71−sizeOfMutableByteArray (MutByteArray arr) =
73− case getSizeofMutableByteArray# arr s of
74− (# s1, i #) -> (# s1, I# i #)
77−touch :: MutByteArray -> IO ()
78−touch (MutByteArray contents) =
79− IO $ \s -> case touch# contents s of s' -> (# s', () #)
81−-- XXX We can provide another API for "unsafe" FFI calls passing an unlifted
82−-- pointer to the FFI call. For unsafe calls we do not need to pin the array.
83−-- We can pass an unlifted pointer to the FFI routine to avoid GC kicking in
84−-- before the pointer is wrapped.
86−-- From the GHC manual:
55+-- Even a non-functional change such as changing the order of constructors will
56+-- change the instance derivation.
88−-- GHC, since version 8.4, guarantees that garbage collection will never occur
58+-- This will not pose a problem if both, encode, and decode are done by the same
89−-- during an unsafe call, even in the bytecode interpreter, and further
59+-- version of the application. There *might* be a problem if version that
90−-- guarantees that unsafe calls will be performed in the calling thread. Making
60+-- encodes differs from the version that decodes.
91−-- it safe to pass heap-allocated objects to unsafe functions.
61+--
92−
62+-- We need to add some compatibility tests using different versions of
93−-- | Use a @MutByteArray@ as @Ptr a@. This is useful when we want to pass
63+-- dependencies.
94−-- an array as a pointer to some operating system call or to a "safe" FFI call.
96−-- If the array is not pinned it is copied to pinned memory before passing it
65+-- Although such chages for the most basic types won't happen we need to detect
97−-- to the monadic action.
66+-- if it ever happens.
99−-- /Performance Notes:/ Forces a copy if the array is not pinned. It is advised
68+-- Should we worry about these kind of changes and this kind of compatibility?
100−-- that the programmer keeps this in mind and creates a pinned array
69+-- This is a problem for all types of derivations that depend on the order of
101−-- opportunistically before this operation occurs, to avoid the cost of a copy
70+-- constructors, for example, Enum.
72+-- Note on Windows build
73+-- =====================
75+-- On Windows, having template haskell splices here fail the build with the
104−-- /Unsafe/ because of direct pointer operations. The user must ensure that
78+-- @
105−-- they are writing within the legal bounds of the array.
79+-- addLibrarySearchPath: C:\... (Win32 error 3): The system cannot find the path specified.
107−-- /Pre-release/
82+-- The error might be irrelavant but having these splices triggers it. We should
83+-- either fix the problem or avoid the use to template haskell splices in this
86+-- Similar issue: https://github.com/haskell/cabal/issues/4741
88+-- $(Serialize.deriveSerialize ''Maybe)
89+instance Serialize a => Serialize (Maybe a) where
109−{-# INLINE asPtrUnsafe #-}
91+ {-# INLINE size #-}
110−asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b
92+ size acc x =
111−asPtrUnsafe arr f = do
93+ case x of
112− contents <- liftIO $ pin arr
94+ Nothing -> (acc + 1)
113− let !ptr = Ptr (byteArrayContents#
95+ Just field0 -> (size (acc + 1)) field0
114− (unsafeCoerce# (getMutableByteArray# contents)))
96+
115− r <- f ptr
97+ {-# INLINE deserialize #-}
116− liftIO $ touch contents
98+ deserialize initialOffset arr endOffset = do
117− return r
99+ (i0, tag) <- ((deserialize initialOffset) arr) endOffset
100+ case tag :: Word8 of
101+ 0 -> pure (i0, Nothing)
102+ 1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
104+ _ -> error "Found invalid tag while peeking (Maybe a)"
106+ {-# INLINE serialize #-}
107+ serialize initialOffset arr val =
110+ i0 <- ((serialize initialOffset) arr) (0 :: Word8)
113+ i0 <- ((serialize initialOffset) arr) (1 :: Word8)
114+ i1 <- ((serialize i0) arr) field0
117+-- $(Serialize.deriveSerialize ''Either)
118+instance (Serialize a, Serialize b) => Serialize (Either a b) where
123+ Left field0 -> (size (acc + 1)) field0
124+ Right field0 -> (size (acc + 1)) field0
126+ {-# INLINE deserialize #-}
127+ deserialize initialOffset arr endOffset = do
128+ (i0, tag) <- ((deserialize initialOffset) arr) endOffset
129+ case tag :: Word8 of
130+ 0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
132+ 1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
134+ _ -> error "Found invalid tag while peeking (Either a b)"
136+ {-# INLINE serialize #-}
137+ serialize initialOffset arr val =
140+ i0 <- ((serialize initialOffset) arr) (0 :: Word8)
141+ i1 <- ((serialize i0) arr) field0
144+ i0 <- ((serialize initialOffset) arr) (1 :: Word8)
145+ i1 <- ((serialize i0) arr) field0
148+instance Serialize (Proxy a) where
151+ size acc _ = (acc + 1)
153+ {-# INLINE deserialize #-}
154+ deserialize initialOffset _ _ = pure ((initialOffset + 1), Proxy)
156+ {-# INLINE serialize #-}
157+ serialize initialOffset _ _ = pure (initialOffset + 1)
119--------------------------------------------------------------------------------
159--------------------------------------------------------------------------------
120−-- Creation
160+-- Integer
121--------------------------------------------------------------------------------
161--------------------------------------------------------------------------------
123−{-# NOINLINE nil #-}
163+data LiftedInteger
124−nil :: MutByteArray
164+ = LIS Int
125−nil = unsafePerformIO $ newByteArray 0
165+ | LIP (Array Word)
126−
166+ | LIN (Array Word)
168+-- $(Serialize.deriveSerialize ''LiftedInteger)
169+instance Serialize LiftedInteger where
127−{-# INLINE newByteArray #-}
171+ {-# INLINE size #-}
128−newByteArray :: Int -> IO MutByteArray
172+ size acc x =
129−newByteArray nbytes | nbytes < 0 =
173+ case x of
130− errorWithoutStackTrace "newByteArray: size must be >= 0"
174+ LIS field0 -> (size (acc + 1)) field0
131−newByteArray (I# nbytes) = IO $ \s ->
175+ LIP field0 -> (size (acc + 1)) field0
132− case newByteArray# nbytes s of
176+ LIN field0 -> (size (acc + 1)) field0
133− (# s', mbarr# #) ->
177+
134− let c = MutByteArray mbarr#
178+ {-# INLINE deserialize #-}
135− in (# s', c #)
179+ deserialize initialOffset arr endOffset = do
136−
180+ (i0, tag) <- ((deserialize initialOffset) arr) endOffset
137−{-# INLINE pinnedNewByteArray #-}
181+ case tag :: Word8 of
138−pinnedNewByteArray :: Int -> IO MutByteArray
182+ 0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
139−pinnedNewByteArray nbytes | nbytes < 0 =
183+ pure (i1, LIS a0)
140− errorWithoutStackTrace "pinnedNewByteArray: size must be >= 0"
184+ 1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
141−pinnedNewByteArray (I# nbytes) = IO $ \s ->
185+ pure (i1, LIP a0)
142− case newPinnedByteArray# nbytes s of
186+ 2 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
143− (# s', mbarr# #) ->
187+ pure (i1, LIN a0)
144− let c = MutByteArray mbarr#
188+ _ -> error "Found invalid tag while peeking (LiftedInteger)"
146−
190+ {-# INLINE serialize #-}
147−{-# INLINE pinnedNewAlignedBytes #-}
191+ serialize initialOffset arr val =
148−pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray
192+ case val of
149−pinnedNewAlignedBytes nbytes _align | nbytes < 0 =
193+ LIS field0 -> do
150− errorWithoutStackTrace "pinnedNewAlignedBytes: size must be >= 0"
194+ i0 <- ((serialize initialOffset) arr) (0 :: Word8)
151−pinnedNewAlignedBytes (I# nbytes) (I# align) = IO $ \s ->
195+ i1 <- ((serialize i0) arr) field0
152− case newAlignedPinnedByteArray# nbytes align s of
196+ pure i1
153− (# s', mbarr# #) ->
197+ LIP field0 -> do
154− let c = MutByteArray mbarr#
198+ i0 <- ((serialize initialOffset) arr) (1 :: Word8)
155− in (# s', c #)
199+ i1 <- ((serialize i0) arr) field0
157−{-# INLINE newBytesAs #-}
201+ LIN field0 -> do
158−newBytesAs :: PinnedState -> Int -> IO MutByteArray
202+ i0 <- ((serialize initialOffset) arr) (2 :: Word8)
159−newBytesAs Unpinned = newByteArray
203+ i1 <- ((serialize i0) arr) field0
160−newBytesAs Pinned = pinnedNewByteArray
204+ pure i1
162−-------------------------------------------------------------------------------
206+#if __GLASGOW_HASKELL__ >= 900
164−-------------------------------------------------------------------------------
208+{-# INLINE liftInteger #-}
165−
209+liftInteger :: Integer -> LiftedInteger
166−-- | Put a sub range of a source array into a subrange of a destination array.
210+liftInteger (IS x) = LIS (I# x)
167−-- This is not safe as it does not check the bounds.
211+liftInteger (IP x) =
168−{-# INLINE putSliceUnsafe #-}
212+ LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
169−putSliceUnsafe ::
213+liftInteger (IN x) =
170− MonadIO m
214+ LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
172− -> Int
216+{-# INLINE unliftInteger #-}
173− -> MutByteArray
217+unliftInteger :: LiftedInteger -> Integer
174− -> Int
218+unliftInteger (LIS (I# x)) = IS x
175− -> Int
219+unliftInteger (LIP (Array (MutByteArray x) _ _)) = IP (unsafeCoerce# x)
176− -> m ()
220+unliftInteger (LIN (Array (MutByteArray x) _ _)) = IN (unsafeCoerce# x)
177−putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do
221+
178−#ifdef DEBUG
222+#else
179− srcLen <- sizeOfMutableByteArray src
223+
180− dstLen <- sizeOfMutableByteArray src
181− when (srcLen - srcStartBytes < lenBytes) $ error "SRC: Insufficient length."
182− when (dstLen - dstStartBytes < lenBytes) $ error "DST: Insufficient length."
184− let !(I# srcStartBytes#) = srcStartBytes
185− !(I# dstStartBytes#) = dstStartBytes
186− !(I# lenBytes#) = lenBytes
187− let arrS# = getMutableByteArray# src
188− arrD# = getMutableByteArray# dst
189− IO $ \s# -> (# copyMutableByteArray#
190− arrS# srcStartBytes# arrD# dstStartBytes# lenBytes# s#
193−-------------------------------------------------------------------------------
194−-- Pinning & Unpinning
195−-------------------------------------------------------------------------------
197−{-# INLINE isPinned #-}
198−isPinned :: MutByteArray -> Bool
199−isPinned (MutByteArray arr#) =
200− let pinnedInt = I# (isMutableByteArrayPinned# arr#)
204−{-# INLINE cloneMutableArrayWith# #-}
205−cloneMutableArrayWith#
206− :: (Int# -> State# RealWorld -> (# State# RealWorld
207− , MutableByteArray# RealWorld #))
208− -> MutableByteArray# RealWorld
210− -> (# State# RealWorld, MutableByteArray# RealWorld #)
211−cloneMutableArrayWith# alloc# arr# s# =
212− case getSizeofMutableByteArray# arr# s# of
214− case alloc# i# s1# of
216− case copyMutableByteArray# arr# 0# arr1# 0# i# s2# of
217− s3# -> (# s3#, arr1# #)
219−{-# INLINE pin #-}
224+{-# INLINE liftInteger #-}
220−pin :: MutByteArray -> IO MutByteArray
225+liftInteger :: Integer -> LiftedInteger
221−pin arr@(MutByteArray marr#) =
226+liftInteger (S# x) = LIS (I# x)
222− if isPinned arr
227+liftInteger (Jp# (BN# x)) =
223− then return arr
228+ LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
224− else
229+liftInteger (Jn# (BN# x)) =
225−#ifdef DEBUG
230+ LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
227− -- XXX dump stack trace
228− trace ("pin: Copying array") (return ())
232− case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
233− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
235−{-# INLINE unpin #-}
232+{-# INLINE unliftInteger #-}
236−unpin :: MutByteArray -> IO MutByteArray
233+unliftInteger :: LiftedInteger -> Integer
237−unpin arr@(MutByteArray marr#) =
234+unliftInteger (LIS (I# x)) = S# x
238− if not (isPinned arr)
235+unliftInteger (LIP (Array (MutByteArray x) _ _)) =
239− then return arr
236+ Jp# (BN# (unsafeCoerce# x))
240− else
237+unliftInteger (LIN (Array (MutByteArray x) _ _)) =
241−#ifdef DEBUG
238+ Jn# (BN# (unsafeCoerce# x))
243− -- XXX dump stack trace
244− trace ("unpin: Copying array") (return ())
247− $ \s# ->
242+instance Serialize Integer where
248− case cloneMutableArrayWith# newByteArray# marr# s# of
243+ {-# INLINE size #-}
249− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
244+ size i a = size i (liftInteger a)
246+ {-# INLINE deserialize #-}
247+ deserialize off arr end = fmap unliftInteger <$> deserialize off arr end
249+ {-# INLINE serialize #-}
250+ serialize off arr val = serialize off arr (liftInteger val)