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