@@ -13,27 +13,8 @@
1313--
1414module Streamly.Internal.Data.Unbox
1515 (
16− -- ** MutByteArray
17− MutByteArray(..)
18− , MutableByteArray
19− , getMutableByteArray#
20− , sizeOfMutableByteArray
21− , nil
22− , putSliceUnsafe
23− , asPtrUnsafe
24−
25− -- ** Allocation
26− , PinnedState(..)
27− , isPinned
28− , pin
29− , unpin
30− , newBytesAs
31− , newByteArray
32− , pinnedNewByteArray
33− , pinnedNewAlignedBytes
34−
3516 -- ** Unbox type class
36− , Unbox(..)
17+ Unbox(..)
3718
3819 -- ** Peek and poke utilities
3920 , BoundedPtr (..)
@@ -59,7 +40,6 @@ module Streamly.Internal.Data.Unbox
5940#include "MachDeps.h"
6041#include "ArrayMacros.h"
6142
62−import Control.Monad.IO.Class (MonadIO(..))
6343import Control.Monad (void, when)
6444import Data.Complex (Complex((:+)))
6545import Data.Functor ((<&>))
@@ -81,217 +61,13 @@ import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..))
8161import GHC.RTS.Flags (IoSubSystem(..))
8262#endif
8363import Streamly.Internal.Data.Builder (Builder (..))
84−import System.IO.Unsafe (unsafePerformIO)
8564
8665import GHC.Generics
8766import GHC.Exts
8867import GHC.TypeLits
8968import Prelude hiding (read)
9069
91−--------------------------------------------------------------------------------
92−-- The ArrayContents type
93−--------------------------------------------------------------------------------
94−
95−data PinnedState
96− = Pinned
97− | Unpinned
98−
99−-- XXX can use UnliftedNewtypes
100−
101−-- | A lifted mutable byte array type wrapping @MutableByteArray# RealWorld@.
102−-- This is a low level array used to back high level unboxed arrays and
103−-- serialized data.
104−data MutByteArray = MutByteArray (MutableByteArray# RealWorld)
105−
106−{-# DEPRECATED MutableByteArray "Please use MutByteArray instead" #-}
107−type MutableByteArray = MutByteArray
108−
109−{-# INLINE getMutableByteArray# #-}
110−getMutableByteArray# :: MutByteArray -> MutableByteArray# RealWorld
111−getMutableByteArray# (MutByteArray mbarr) = mbarr
112−
113−-- | Return the size of the array in bytes.
114−{-# INLINE sizeOfMutableByteArray #-}
115−sizeOfMutableByteArray :: MutByteArray -> IO Int
116−sizeOfMutableByteArray (MutByteArray arr) =
117− IO $ \s ->
118− case getSizeofMutableByteArray# arr s of
119− (# s1, i #) -> (# s1, I# i #)
120−
121−{-# INLINE touch #-}
122−touch :: MutByteArray -> IO ()
123−touch (MutByteArray contents) =
124− IO $ \s -> case touch# contents s of s' -> (# s', () #)
125−
126−-- XXX We can provide another API for "unsafe" FFI calls passing an unlifted
127−-- pointer to the FFI call. For unsafe calls we do not need to pin the array.
128−-- We can pass an unlifted pointer to the FFI routine to avoid GC kicking in
129−-- before the pointer is wrapped.
130−--
131−-- From the GHC manual:
132−--
133−-- GHC, since version 8.4, guarantees that garbage collection will never occur
134−-- during an unsafe call, even in the bytecode interpreter, and further
135−-- guarantees that unsafe calls will be performed in the calling thread. Making
136−-- it safe to pass heap-allocated objects to unsafe functions.
137−
138−-- | Use a @MutByteArray@ as @Ptr a@. This is useful when we want to pass
139−-- an array as a pointer to some operating system call or to a "safe" FFI call.
140−--
141−-- If the array is not pinned it is copied to pinned memory before passing it
142−-- to the monadic action.
143−--
144−-- /Performance Notes:/ Forces a copy if the array is not pinned. It is advised
145−-- that the programmer keeps this in mind and creates a pinned array
146−-- opportunistically before this operation occurs, to avoid the cost of a copy
147−-- if possible.
148−--
149−-- /Unsafe/ because of direct pointer operations. The user must ensure that
150−-- they are writing within the legal bounds of the array.
151−--
152−-- /Pre-release/
153−--
154−{-# INLINE asPtrUnsafe #-}
155−asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b
156−asPtrUnsafe arr f = do
157− contents <- liftIO $ pin arr
158− let !ptr = Ptr (byteArrayContents#
159− (unsafeCoerce# (getMutableByteArray# contents)))
160− r <- f ptr
161− liftIO $ touch contents
162− return r
163−
164−--------------------------------------------------------------------------------
165−-- Creation
166−--------------------------------------------------------------------------------
167−
168−{-# NOINLINE nil #-}
169−nil :: MutByteArray
170−nil = unsafePerformIO $ newByteArray 0
171−
172−{-# INLINE newByteArray #-}
173−newByteArray :: Int -> IO MutByteArray
174−newByteArray nbytes | nbytes < 0 =
175− errorWithoutStackTrace "newByteArray: size must be >= 0"
176−newByteArray (I# nbytes) = IO $ \s ->
177− case newByteArray# nbytes s of
178− (# s', mbarr# #) ->
179− let c = MutByteArray mbarr#
180− in (# s', c #)
181−
182−{-# INLINE pinnedNewByteArray #-}
183−pinnedNewByteArray :: Int -> IO MutByteArray
184−pinnedNewByteArray nbytes | nbytes < 0 =
185− errorWithoutStackTrace "pinnedNewByteArray: size must be >= 0"
186−pinnedNewByteArray (I# nbytes) = IO $ \s ->
187− case newPinnedByteArray# nbytes s of
188− (# s', mbarr# #) ->
189− let c = MutByteArray mbarr#
190− in (# s', c #)
191−
192−{-# INLINE pinnedNewAlignedBytes #-}
193−pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray
194−pinnedNewAlignedBytes nbytes _align | nbytes < 0 =
195− errorWithoutStackTrace "pinnedNewAlignedBytes: size must be >= 0"
196−pinnedNewAlignedBytes (I# nbytes) (I# align) = IO $ \s ->
197− case newAlignedPinnedByteArray# nbytes align s of
198− (# s', mbarr# #) ->
199− let c = MutByteArray mbarr#
200− in (# s', c #)
201−
202−{-# INLINE newBytesAs #-}
203−newBytesAs :: PinnedState -> Int -> IO MutByteArray
204−newBytesAs Unpinned = newByteArray
205−newBytesAs Pinned = pinnedNewByteArray
206−
207−-------------------------------------------------------------------------------
208−-- Copying
209−-------------------------------------------------------------------------------
210−
211−-- | Put a sub range of a source array into a subrange of a destination array.
212−-- This is not safe as it does not check the bounds.
213−{-# INLINE putSliceUnsafe #-}
214−putSliceUnsafe ::
215− MonadIO m
216− => MutByteArray
217− -> Int
218− -> MutByteArray
219− -> Int
220− -> Int
221− -> m ()
222−putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do
223−#ifdef DEBUG
224− srcLen <- sizeOfMutableByteArray src
225− dstLen <- sizeOfMutableByteArray src
226− when (srcLen - srcStartBytes < lenBytes) $ error "SRC: Insufficient length."
227− when (dstLen - dstStartBytes < lenBytes) $ error "DST: Insufficient length."
228−#endif
229− let !(I# srcStartBytes#) = srcStartBytes
230− !(I# dstStartBytes#) = dstStartBytes
231− !(I# lenBytes#) = lenBytes
232− let arrS# = getMutableByteArray# src
233− arrD# = getMutableByteArray# dst
234− IO $ \s# -> (# copyMutableByteArray#
235− arrS# srcStartBytes# arrD# dstStartBytes# lenBytes# s#
236− , () #)
237−
238−-------------------------------------------------------------------------------
239−-- Pinning & Unpinning
240−-------------------------------------------------------------------------------
241−
242−{-# INLINE isPinned #-}
243−isPinned :: MutByteArray -> Bool
244−isPinned (MutByteArray arr#) =
245− let pinnedInt = I# (isMutableByteArrayPinned# arr#)
246− in pinnedInt /= 0
247−
248−
249−{-# INLINE cloneMutableArrayWith# #-}
250−cloneMutableArrayWith#
251− :: (Int# -> State# RealWorld -> (# State# RealWorld
252− , MutableByteArray# RealWorld #))
253− -> MutableByteArray# RealWorld
254− -> State# RealWorld
255− -> (# State# RealWorld, MutableByteArray# RealWorld #)
256−cloneMutableArrayWith# alloc# arr# s# =
257− case getSizeofMutableByteArray# arr# s# of
258− (# s1#, i# #) ->
259− case alloc# i# s1# of
260− (# s2#, arr1# #) ->
261− case copyMutableByteArray# arr# 0# arr1# 0# i# s2# of
262− s3# -> (# s3#, arr1# #)
263−
264−{-# INLINE pin #-}
265−pin :: MutByteArray -> IO MutByteArray
266−pin arr@(MutByteArray marr#) =
267− if isPinned arr
268− then return arr
269− else
270−#ifdef DEBUG
271− do
272− -- XXX dump stack trace
273− trace ("pin: Copying array") (return ())
274−#endif
275− IO
276− $ \s# ->
277− case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
278− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
279−
280−{-# INLINE unpin #-}
281−unpin :: MutByteArray -> IO MutByteArray
282−unpin arr@(MutByteArray marr#) =
283− if not (isPinned arr)
284− then return arr
285− else
286−#ifdef DEBUG
287− do
288− -- XXX dump stack trace
289− trace ("unpin: Copying array") (return ())
290−#endif
291− IO
292− $ \s# ->
293− case cloneMutableArrayWith# newByteArray# marr# s# of
294− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
70+import Streamly.Internal.Data.MutByteArray (MutByteArray(..))
29571
29672--------------------------------------------------------------------------------
29773-- The Unbox type class