@@ -13,27 +13,8 @@
14module Streamly.Internal.Data.Unbox
14module Streamly.Internal.Data.Unbox
19− , getMutableByteArray#
20− , sizeOfMutableByteArray
33− , pinnedNewAlignedBytes
35 -- ** Unbox type class
16 -- ** Unbox type class
36− , Unbox(..)
17+ Unbox(..)
38 -- ** Peek and poke utilities
19 -- ** Peek and poke utilities
39 , BoundedPtr (..)
20 , BoundedPtr (..)
@@ -59,7 +40,6 @@ module Streamly.Internal.Data.Unbox
59#include "MachDeps.h"
40#include "MachDeps.h"
60#include "ArrayMacros.h"
41#include "ArrayMacros.h"
62−import Control.Monad.IO.Class (MonadIO(..))
63import Control.Monad (void, when)
43import Control.Monad (void, when)
64import Data.Complex (Complex((:+)))
44import Data.Complex (Complex((:+)))
65import Data.Functor ((<&>))
45import Data.Functor ((<&>))
@@ -81,217 +61,13 @@ import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..))
81import GHC.RTS.Flags (IoSubSystem(..))
61import GHC.RTS.Flags (IoSubSystem(..))
83import Streamly.Internal.Data.Builder (Builder (..))
63import Streamly.Internal.Data.Builder (Builder (..))
84−import System.IO.Unsafe (unsafePerformIO)
86import GHC.Generics
65import GHC.Generics
87import GHC.Exts
66import GHC.Exts
88import GHC.TypeLits
67import GHC.TypeLits
89import Prelude hiding (read)
68import Prelude hiding (read)
91−--------------------------------------------------------------------------------
70+import Streamly.Internal.Data.MutByteArray (MutByteArray(..))
92−-- The ArrayContents type
93−--------------------------------------------------------------------------------
99−-- XXX can use UnliftedNewtypes
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
104−data MutByteArray = MutByteArray (MutableByteArray# RealWorld)
106−{-# DEPRECATED MutableByteArray "Please use MutByteArray instead" #-}
107−type MutableByteArray = MutByteArray
109−{-# INLINE getMutableByteArray# #-}
110−getMutableByteArray# :: MutByteArray -> MutableByteArray# RealWorld
111−getMutableByteArray# (MutByteArray mbarr) = mbarr
113−-- | Return the size of the array in bytes.
114−{-# INLINE sizeOfMutableByteArray #-}
115−sizeOfMutableByteArray :: MutByteArray -> IO Int
116−sizeOfMutableByteArray (MutByteArray arr) =
118− case getSizeofMutableByteArray# arr s of
119− (# s1, i #) -> (# s1, I# i #)
122−touch :: MutByteArray -> IO ()
123−touch (MutByteArray contents) =
124− IO $ \s -> case touch# contents s of s' -> (# s', () #)
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.
131−-- From the GHC manual:
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.
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.
141−-- If the array is not pinned it is copied to pinned memory before passing it
142−-- to the monadic action.
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
149−-- /Unsafe/ because of direct pointer operations. The user must ensure that
150−-- they are writing within the legal bounds of the array.
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)))
161− liftIO $ touch contents
164−--------------------------------------------------------------------------------
166−--------------------------------------------------------------------------------
170−nil = unsafePerformIO $ newByteArray 0
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
179− let c = MutByteArray mbarr#
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
189− let c = MutByteArray mbarr#
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
199− let c = MutByteArray mbarr#
202−{-# INLINE newBytesAs #-}
203−newBytesAs :: PinnedState -> Int -> IO MutByteArray
204−newBytesAs Unpinned = newByteArray
205−newBytesAs Pinned = pinnedNewByteArray
207−-------------------------------------------------------------------------------
209−-------------------------------------------------------------------------------
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 #-}
222−putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do
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."
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#
238−-------------------------------------------------------------------------------
239−-- Pinning & Unpinning
240−-------------------------------------------------------------------------------
242−{-# INLINE isPinned #-}
243−isPinned :: MutByteArray -> Bool
244−isPinned (MutByteArray arr#) =
245− let pinnedInt = I# (isMutableByteArrayPinned# arr#)
249−{-# INLINE cloneMutableArrayWith# #-}
250−cloneMutableArrayWith#
251− :: (Int# -> State# RealWorld -> (# State# RealWorld
252− , MutableByteArray# RealWorld #))
253− -> MutableByteArray# RealWorld
255− -> (# State# RealWorld, MutableByteArray# RealWorld #)
256−cloneMutableArrayWith# alloc# arr# s# =
257− case getSizeofMutableByteArray# arr# s# of
259− case alloc# i# s1# of
261− case copyMutableByteArray# arr# 0# arr1# 0# i# s2# of
262− s3# -> (# s3#, arr1# #)
265−pin :: MutByteArray -> IO MutByteArray
266−pin arr@(MutByteArray marr#) =
272− -- XXX dump stack trace
273− trace ("pin: Copying array") (return ())
277− case cloneMutableArrayWith# newPinnedByteArray# marr# s# of
278− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
281−unpin :: MutByteArray -> IO MutByteArray
282−unpin arr@(MutByteArray marr#) =
283− if not (isPinned arr)
288− -- XXX dump stack trace
289− trace ("unpin: Copying array") (return ())
293− case cloneMutableArrayWith# newByteArray# marr# s# of
294− (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #)
296--------------------------------------------------------------------------------
72--------------------------------------------------------------------------------
297-- The Unbox type class
73-- The Unbox type class