git.iko.soy/streamly
on 70fbefe help sign in
streamly/src/Streamly/Internal/Ring/Foreign.hs
252 lines 9.4 kB history raw
1-- |
2-- Module : Streamly.Internal.Ring.Foreign
3-- Copyright : (c) 2019 Composewell Technologies
4-- License : BSD3
5-- Maintainer : streamly@composewell.com
6-- Stability : experimental
7-- Portability : GHC
8--
10module Streamly.Internal.Ring.Foreign
11 ( Ring(..)
13 -- * Construction
14 , new
15 , advance
16 , moveBy
17 , startOf
19 -- * Modification
20 , unsafeInsert
22 -- * Folds
23 , unsafeFoldRing
24 , unsafeFoldRingM
25 , unsafeFoldRingFullM
26 , unsafeFoldRingNM
28 -- * Fast Byte Comparisons
29 , unsafeEqArray
30 , unsafeEqArrayN
31 ) where
33import Control.Exception (assert)
34import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr)
35import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
36import Foreign.Ptr (plusPtr, minusPtr, castPtr)
37import Foreign.Storable (Storable(..))
38import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes)
39import GHC.Ptr (Ptr(..))
40import Prelude hiding (length, concat)
42import Control.Monad.IO.Class (MonadIO(..))
43import Streamly.Internal.Data.Array.Foreign.Mut.Type (memcmp)
44import Streamly.Internal.System.IO (unsafeInlineIO)
46import qualified Streamly.Internal.Data.Array.Foreign.Type as A
48-- | A ring buffer is a mutable array of fixed size. Initially the array is
49-- empty, with ringStart pointing at the start of allocated memory. We call the
50-- next location to be written in the ring as ringHead. Initially ringHead ==
51-- ringStart. When the first item is added, ringHead points to ringStart +
52-- sizeof item. When the buffer becomes full ringHead would wrap around to
53-- ringStart. When the buffer is full, ringHead always points at the oldest
54-- item in the ring and the newest item added always overwrites the oldest
55-- item.
56--
57-- When using it we should keep in mind that a ringBuffer is a mutable data
58-- structure. We should not leak out references to it for immutable use.
59--
60data Ring a = Ring
61 { ringStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address
62 , ringBound :: {-# UNPACK #-} !(Ptr a) -- first address beyond allocated memory
63 }
65-- | Get the first address of the ring as a pointer.
66startOf :: Ring a -> Ptr a
67startOf = unsafeForeignPtrToPtr . ringStart
69-- | Create a new ringbuffer and return the ring buffer and the ringHead.
70-- Returns the ring and the ringHead, the ringHead is same as ringStart.
71{-# INLINE new #-}
72new :: forall a. Storable a => Int -> IO (Ring a, Ptr a)
73new count = do
74 let size = count * sizeOf (undefined :: a)
75 fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a))
76 let p = unsafeForeignPtrToPtr fptr
77 return (Ring
78 { ringStart = fptr
79 , ringBound = p `plusPtr` size
80 }, p)
82-- | Advance the ringHead by 1 item, wrap around if we hit the end of the
83-- array.
84{-# INLINE advance #-}
85advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a
86advance Ring{..} ringHead =
87 let ptr = ringHead `plusPtr` sizeOf (undefined :: a)
88 in if ptr < ringBound
89 then ptr
90 else unsafeForeignPtrToPtr ringStart
92-- | Move the ringHead by n items. The direction depends on the sign on whether
93-- n is positive or negative. Wrap around if we hit the beginning or end of the
94-- array.
95{-# INLINE moveBy #-}
96moveBy :: forall a. Storable a => Int -> Ring a -> Ptr a -> Ptr a
97moveBy by Ring {..} ringHead = ringStartPtr `plusPtr` advanceFromHead
99 where
101 elemSize = sizeOf (undefined :: a)
102 ringStartPtr = unsafeForeignPtrToPtr ringStart
103 lenInBytes = ringBound `minusPtr` ringStartPtr
104 offInBytes = ringHead `minusPtr` ringStartPtr
105 len = assert (lenInBytes `mod` elemSize == 0) $ lenInBytes `div` elemSize
106 off = assert (offInBytes `mod` elemSize == 0) $ offInBytes `div` elemSize
107 advanceFromHead = (off + by `mod` len) * elemSize
109-- | Insert an item at the head of the ring, when the ring is full this
110-- replaces the oldest item in the ring with the new item. This is unsafe
111-- beause ringHead supplied is not verified to be within the Ring. Also,
112-- the ringStart foreignPtr must be guaranteed to be alive by the caller.
113{-# INLINE unsafeInsert #-}
114unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a)
115unsafeInsert rb ringHead newVal = do
116 poke ringHead newVal
117 -- touchForeignPtr (ringStart rb)
118 return $ advance rb ringHead
120-- XXX remove all usage of unsafeInlineIO
121--
122-- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of
123-- the ring buffer. This is unsafe because the ringHead Ptr is not checked to
124-- be in range.
125{-# INLINE unsafeEqArrayN #-}
126unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool
127unsafeEqArrayN Ring{..} rh A.Array{..} n =
128 let !res = unsafeInlineIO $ do
129 let rs = unsafeForeignPtrToPtr ringStart
130 as = unsafeForeignPtrToPtr aStart
131 assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) (return ())
132 let len = ringBound `minusPtr` rh
133 r1 <- memcmp (castPtr rh) (castPtr as) (min len n)
134 r2 <- if n > len
135 then memcmp (castPtr rs) (castPtr (as `plusPtr` len))
136 (min (rh `minusPtr` rs) (n - len))
137 else return True
138 -- XXX enable these, check perf impact
139 -- touchForeignPtr ringStart
140 -- touchForeignPtr aStart
141 return (r1 && r2)
142 in res
144-- | Byte compare the entire length of ringBuffer with the given array,
145-- starting at the supplied ringHead pointer. Returns true if the Array and
146-- the ringBuffer have identical contents.
147--
148-- This is unsafe because the ringHead Ptr is not checked to be in range. The
149-- supplied array must be equal to or bigger than the ringBuffer, ARRAY BOUNDS
150-- ARE NOT CHECKED.
151{-# INLINE unsafeEqArray #-}
152unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool
153unsafeEqArray Ring{..} rh A.Array{..} =
154 let !res = unsafeInlineIO $ do
155 let rs = unsafeForeignPtrToPtr ringStart
156 let as = unsafeForeignPtrToPtr aStart
157 assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs)
158 (return ())
159 let len = ringBound `minusPtr` rh
160 r1 <- memcmp (castPtr rh) (castPtr as) len
161 r2 <- memcmp (castPtr rs) (castPtr (as `plusPtr` len))
162 (rh `minusPtr` rs)
163 -- XXX enable these, check perf impact
164 -- touchForeignPtr ringStart
165 -- touchForeignPtr aStart
166 return (r1 && r2)
167 in res
169-- XXX use MonadIO
170--
171-- | Fold the buffer starting from ringStart up to the given 'Ptr' using a pure
172-- step function. This is useful to fold the items in the ring when the ring is
173-- not full. The supplied pointer is usually the end of the ring.
174--
175-- Unsafe because the supplied Ptr is not checked to be in range.
176{-# INLINE unsafeFoldRing #-}
177unsafeFoldRing :: forall a b. Storable a
178 => Ptr a -> (b -> a -> b) -> b -> Ring a -> b
179unsafeFoldRing ptr f z Ring{..} =
180 let !res = unsafeInlineIO $ withForeignPtr ringStart $ \p ->
181 go z p ptr
182 in res
183 where
184 go !acc !p !q
185 | p == q = return acc
186 | otherwise = do
187 x <- peek p
188 go (f acc x) (p `plusPtr` sizeOf (undefined :: a)) q
190-- XXX Can we remove MonadIO here?
191withForeignPtrM :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
192withForeignPtrM fp fn = do
193 r <- fn $ unsafeForeignPtrToPtr fp
194 liftIO $ touchForeignPtr fp
195 return r
197-- | Like unsafeFoldRing but with a monadic step function.
198{-# INLINE unsafeFoldRingM #-}
199unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a)
200 => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b
201unsafeFoldRingM ptr f z Ring {..} =
202 withForeignPtrM ringStart $ \x -> go z x ptr
203 where
204 go !acc !start !end
205 | start == end = return acc
206 | otherwise = do
207 let !x = unsafeInlineIO $ peek start
208 acc' <- f acc x
209 go acc' (start `plusPtr` sizeOf (undefined :: a)) end
211-- | Fold the entire length of a ring buffer starting at the supplied ringHead
212-- pointer. Assuming the supplied ringHead pointer points to the oldest item,
213-- this would fold the ring starting from the oldest item to the newest item in
214-- the ring.
215--
216-- Note, this will crash on ring of 0 size.
217--
218{-# INLINE unsafeFoldRingFullM #-}
219unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a)
220 => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b
221unsafeFoldRingFullM rh f z rb@Ring {..} =
222 withForeignPtrM ringStart $ \_ -> go z rh
223 where
224 go !acc !start = do
225 let !x = unsafeInlineIO $ peek start
226 acc' <- f acc x
227 let ptr = advance rb start
228 if ptr == rh
229 then return acc'
230 else go acc' ptr
232-- | Fold @Int@ items in the ring starting at @Ptr a@. Won't fold more
233-- than the length of the ring.
234--
235-- Note, this will crash on ring of 0 size.
236--
237{-# INLINE unsafeFoldRingNM #-}
238unsafeFoldRingNM :: forall m a b. (MonadIO m, Storable a)
239 => Int -> Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b
240unsafeFoldRingNM count rh f z rb@Ring {..} =
241 withForeignPtrM ringStart $ \_ -> go count z rh
243 where
245 go 0 acc _ = return acc
246 go !n !acc !start = do
247 let !x = unsafeInlineIO $ peek start
248 acc' <- f acc x
249 let ptr = advance rb start
250 if ptr == rh || n == 0
251 then return acc'
252 else go (n - 1) acc' ptr