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