1{-# LANGUAGE Trustworthy #-}
2{-# LANGUAGE BangPatterns, CPP, NoImplicitPrelude #-}
3
4module GHC.Event.Array
5    (
6      Array
7    , capacity
8    , clear
9    , concat
10    , copy
11    , duplicate
12    , empty
13    , ensureCapacity
14    , findIndex
15    , forM_
16    , length
17    , loop
18    , new
19    , removeAt
20    , snoc
21    , unsafeLoad
22    , unsafeRead
23    , unsafeWrite
24    , useAsPtr
25    ) where
26
27import Data.Bits ((.|.), shiftR)
28import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
29import Data.Maybe
30import Foreign.C.Types (CSize(..))
31import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
32import Foreign.Ptr (Ptr, nullPtr, plusPtr)
33import Foreign.Storable (Storable(..))
34import GHC.Base hiding (empty)
35import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_)
36import GHC.Num (Num(..))
37import GHC.Real (fromIntegral)
38import GHC.Show (show)
39
40#include "MachDeps.h"
41
42#define BOUNDS_CHECKING 1
43
44#if defined(BOUNDS_CHECKING)
45-- This fugly hack is brought by GHC's apparent reluctance to deal
46-- with MagicHash and UnboxedTuples when inferring types. Eek!
47#define CHECK_BOUNDS(_func_,_len_,_k_) \
48if (_k_) < 0 || (_k_) >= (_len_) then errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else
49#else
50#define CHECK_BOUNDS(_func_,_len_,_k_)
51#endif
52
53-- Invariant: size <= capacity
54newtype Array a = Array (IORef (AC a))
55
56-- The actual array content.
57data AC a = AC
58    !(ForeignPtr a)  -- Elements
59    !Int      -- Number of elements (length)
60    !Int      -- Maximum number of elements (capacity)
61
62empty :: IO (Array a)
63empty = do
64  p <- newForeignPtr_ nullPtr
65  Array `fmap` newIORef (AC p 0 0)
66
67allocArray :: Storable a => Int -> IO (ForeignPtr a)
68allocArray n = allocHack undefined
69 where
70  allocHack :: Storable a => a -> IO (ForeignPtr a)
71  allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy)
72
73reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a)
74reallocArray p newSize oldSize = reallocHack undefined p
75 where
76  reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a)
77  reallocHack dummy src = do
78      let size = sizeOf dummy
79      dst <- mallocPlainForeignPtrBytes (newSize * size)
80      withForeignPtr src $ \s ->
81        when (s /= nullPtr && oldSize > 0) .
82          withForeignPtr dst $ \d -> do
83            _ <- memcpy d s (fromIntegral (oldSize * size))
84            return ()
85      return dst
86
87new :: Storable a => Int -> IO (Array a)
88new c = do
89    es <- allocArray cap
90    fmap Array (newIORef (AC es 0 cap))
91  where
92    cap = firstPowerOf2 c
93
94duplicate :: Storable a => Array a -> IO (Array a)
95duplicate a = dupHack undefined a
96 where
97  dupHack :: Storable b => b -> Array b -> IO (Array b)
98  dupHack dummy (Array ref) = do
99    AC es len cap <- readIORef ref
100    ary <- allocArray cap
101    withForeignPtr ary $ \dest ->
102      withForeignPtr es $ \src -> do
103        _ <- memcpy dest src (fromIntegral (len * sizeOf dummy))
104        return ()
105    Array `fmap` newIORef (AC ary len cap)
106
107length :: Array a -> IO Int
108length (Array ref) = do
109    AC _ len _ <- readIORef ref
110    return len
111
112capacity :: Array a -> IO Int
113capacity (Array ref) = do
114    AC _ _ cap <- readIORef ref
115    return cap
116
117unsafeRead :: Storable a => Array a -> Int -> IO a
118unsafeRead (Array ref) ix = do
119    AC es _ cap <- readIORef ref
120    CHECK_BOUNDS("unsafeRead",cap,ix)
121      withForeignPtr es $ \p ->
122        peekElemOff p ix
123
124unsafeWrite :: Storable a => Array a -> Int -> a -> IO ()
125unsafeWrite (Array ref) ix a = do
126    ac <- readIORef ref
127    unsafeWrite' ac ix a
128
129unsafeWrite' :: Storable a => AC a -> Int -> a -> IO ()
130unsafeWrite' (AC es _ cap) ix a = do
131    CHECK_BOUNDS("unsafeWrite'",cap,ix)
132      withForeignPtr es $ \p ->
133        pokeElemOff p ix a
134
135unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int
136unsafeLoad (Array ref) load = do
137    AC es _ cap <- readIORef ref
138    len' <- withForeignPtr es $ \p -> load p cap
139    writeIORef ref (AC es len' cap)
140    return len'
141
142ensureCapacity :: Storable a => Array a -> Int -> IO ()
143ensureCapacity (Array ref) c = do
144    ac@(AC _ _ cap) <- readIORef ref
145    ac'@(AC _ _ cap') <- ensureCapacity' ac c
146    when (cap' /= cap) $
147      writeIORef ref ac'
148
149ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a)
150ensureCapacity' ac@(AC es len cap) c = do
151    if c > cap
152      then do
153        es' <- reallocArray es cap' cap
154        return (AC es' len cap')
155      else
156        return ac
157  where
158    cap' = firstPowerOf2 c
159
160useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b
161useAsPtr (Array ref) f = do
162    AC es len _ <- readIORef ref
163    withForeignPtr es $ \p -> f p len
164
165snoc :: Storable a => Array a -> a -> IO ()
166snoc (Array ref) e = do
167    ac@(AC _ len _) <- readIORef ref
168    let len' = len + 1
169    ac'@(AC es _ cap) <- ensureCapacity' ac len'
170    unsafeWrite' ac' len e
171    writeIORef ref (AC es len' cap)
172
173clear :: Array a -> IO ()
174clear (Array ref) = do
175  atomicModifyIORef' ref $ \(AC es _ cap) ->
176        (AC es 0 cap, ())
177
178forM_ :: Storable a => Array a -> (a -> IO ()) -> IO ()
179forM_ ary g = forHack ary g undefined
180  where
181    forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO ()
182    forHack (Array ref) f dummy = do
183      AC es len _ <- readIORef ref
184      let size = sizeOf dummy
185          offset = len * size
186      withForeignPtr es $ \p -> do
187        let go n | n >= offset = return ()
188                 | otherwise = do
189              f =<< peek (p `plusPtr` n)
190              go (n + size)
191        go 0
192
193loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO ()
194loop ary z g = loopHack ary z g undefined
195  where
196    loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b
197             -> IO ()
198    loopHack (Array ref) y f dummy = do
199      AC es len _ <- readIORef ref
200      let size = sizeOf dummy
201          offset = len * size
202      withForeignPtr es $ \p -> do
203        let go n k
204                | n >= offset = return ()
205                | otherwise = do
206                      (k',cont) <- f k =<< peek (p `plusPtr` n)
207                      when cont $ go (n + size) k'
208        go 0 y
209
210findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a))
211findIndex = findHack undefined
212 where
213  findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b))
214  findHack dummy p (Array ref) = do
215    AC es len _ <- readIORef ref
216    let size   = sizeOf dummy
217        offset = len * size
218    withForeignPtr es $ \ptr ->
219      let go !n !i
220            | n >= offset = return Nothing
221            | otherwise = do
222                val <- peek (ptr `plusPtr` n)
223                if p val
224                  then return $ Just (i, val)
225                  else go (n + size) (i + 1)
226      in  go 0 0
227
228concat :: Storable a => Array a -> Array a -> IO ()
229concat (Array d) (Array s) = do
230  da@(AC _ dlen _) <- readIORef d
231  sa@(AC _ slen _) <- readIORef s
232  writeIORef d =<< copy' da dlen sa 0 slen
233
234-- | Copy part of the source array into the destination array. The
235-- destination array is resized if not large enough.
236copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO ()
237copy (Array d) dstart (Array s) sstart maxCount = do
238  da <- readIORef d
239  sa <- readIORef s
240  writeIORef d =<< copy' da dstart sa sstart maxCount
241
242-- | Copy part of the source array into the destination array. The
243-- destination array is resized if not large enough.
244copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a)
245copy' d dstart s sstart maxCount = copyHack d s undefined
246 where
247  copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b)
248  copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do
249    when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 ||
250          sstart > slen) $ errorWithoutStackTrace "copy: bad offsets or lengths"
251    let size = sizeOf dummy
252        count = min maxCount (slen - sstart)
253    if count == 0
254      then return dac
255      else do
256        AC dst dlen dcap <- ensureCapacity' dac (dstart + count)
257        withForeignPtr dst $ \dptr ->
258          withForeignPtr src $ \sptr -> do
259            _ <- memcpy (dptr `plusPtr` (dstart * size))
260                        (sptr `plusPtr` (sstart * size))
261                        (fromIntegral (count * size))
262            return $ AC dst (max dlen (dstart + count)) dcap
263
264removeAt :: Storable a => Array a -> Int -> IO ()
265removeAt a i = removeHack a undefined
266 where
267  removeHack :: Storable b => Array b -> b -> IO ()
268  removeHack (Array ary) dummy = do
269    AC fp oldLen cap <- readIORef ary
270    when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index"
271    let size   = sizeOf dummy
272        newLen = oldLen - 1
273    when (newLen > 0 && i < newLen) .
274      withForeignPtr fp $ \ptr -> do
275        _ <- memmove (ptr `plusPtr` (size * i))
276                     (ptr `plusPtr` (size * (i+1)))
277                     (fromIntegral (size * (newLen-i)))
278        return ()
279    writeIORef ary (AC fp newLen cap)
280
281{-The firstPowerOf2 function works by setting all bits on the right-hand
282side of the most significant flagged bit to 1, and then incrementing
283the entire value at the end so it "rolls over" to the nearest power of
284two.
285-}
286
287-- | Computes the next-highest power of two for a particular integer,
288-- @n@.  If @n@ is already a power of two, returns @n@.  If @n@ is
289-- zero, returns zero, even though zero is not a power of two.
290firstPowerOf2 :: Int -> Int
291firstPowerOf2 !n =
292    let !n1 = n - 1
293        !n2 = n1 .|. (n1 `shiftR` 1)
294        !n3 = n2 .|. (n2 `shiftR` 2)
295        !n4 = n3 .|. (n3 `shiftR` 4)
296        !n5 = n4 .|. (n4 `shiftR` 8)
297        !n6 = n5 .|. (n5 `shiftR` 16)
298#if WORD_SIZE_IN_BITS == 32
299    in n6 + 1
300#elif WORD_SIZE_IN_BITS == 64
301        !n7 = n6 .|. (n6 `shiftR` 32)
302    in n7 + 1
303#else
304# error firstPowerOf2 not defined on this architecture
305#endif
306
307foreign import ccall unsafe "string.h memcpy"
308    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
309
310foreign import ccall unsafe "string.h memmove"
311    memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
312
313