--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
--- Portability : non-portable
+-- Portability : non-portable (uses Data.Array.IArray)
--
-- Functional arrays with constant-time update.
--
import Foreign.Ptr ( Ptr, FunPtr )
import Foreign.StablePtr ( StablePtr )
import Data.Int ( Int8, Int16, Int32, Int64 )
-#ifdef __GLASGOW_HASKELL__
-import Data.Word ( Word )
-#endif
-import Data.Word ( Word8, Word16, Word32, Word64 )
+import Data.Word ( Word, Word8, Word16, Word32, Word64 )
import System.IO.Unsafe ( unsafePerformIO )
+import Control.Exception ( evaluate )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )
------------------------------------------------------------------------
instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
showsPrec = showsIArray
-#ifdef __GLASGOW_HASKELL__
instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
showsPrec = showsIArray
-#endif
instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
showsPrec = showsIArray
------------------------------------------------------------------------
-- Boring instances.
-instance HasBounds a => HasBounds (IOToDiffArray a) where
- bounds a = unsafePerformIO $ boundsDiffArray a
-
instance IArray (IOToDiffArray IOArray) e where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies
instance IArray (IOToDiffArray IOUArray) Char where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Int where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-#ifdef __GLASGOW_HASKELL__
instance IArray (IOToDiffArray IOUArray) Word where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
-#endif
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) (Ptr a) where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) (FunPtr a) where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Float where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Double where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) (StablePtr a) where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Int8 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Int16 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Int32 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Int64 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Word8 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Word16 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Word32 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance IArray (IOToDiffArray IOUArray) Word64 where
+ bounds a = unsafePerformIO $ boundsDiffArray a
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray` ies
+ unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
var' <- newMVar (Current a')
return (DiffArray var')
-boundsDiffArray :: (HasBounds a, Ix ix)
+-- The elements of the diff list might recursively reference the
+-- array, so we must seq them before taking the MVar to avoid
+-- deadlock.
+replaceDiffArray1 :: (MArray a e IO, Ix i)
+ => IOToDiffArray a i e
+ -> [(Int, e)]
+ -> IO (IOToDiffArray a i e)
+a `replaceDiffArray1` ies = do
+ mapM_ (evaluate . fst) ies
+ a `replaceDiffArray` ies
+
+-- If the array contains unboxed elements, then the elements of the
+-- diff list may also recursively reference the array from inside
+-- replaceDiffArray, so we must seq them too.
+replaceDiffArray2 :: (MArray a e IO, Ix i)
+ => IOToDiffArray a i e
+ -> [(Int, e)]
+ -> IO (IOToDiffArray a i e)
+a `replaceDiffArray2` ies = do
+ mapM_ (\(a,b) -> do evaluate a; evaluate b) ies
+ a `replaceDiffArray` ies
+
+
+boundsDiffArray :: (MArray a e IO, Ix ix)
=> IOToDiffArray a ix e
-> IO (ix,ix)
boundsDiffArray a = do
d <- readMVar (varDiffArray a)
case d of
- Current a' -> return (bounds a')
+ Current a' -> getBounds a'
Diff a' _ -> boundsDiffArray a'
freezeDiffArray :: (MArray a e IO, Ix ix)
=> a ix e
-> IO (IOToDiffArray a ix e)
-freezeDiffArray a = case bounds a of
- (l,u) -> do
- a' <- newArray_ (l,u)
- sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
- var <- newMVar (Current a')
- return (DiffArray var)
+freezeDiffArray a = do
+ (l,u) <- getBounds a
+ a' <- newArray_ (l,u)
+ sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
+ var <- newMVar (Current a')
+ return (DiffArray var)
{-# RULES
"freeze/DiffArray" freeze = freezeDiffArray
thawDiffArray a = do
d <- readMVar (varDiffArray a)
case d of
- Current a' -> case bounds a' of
- (l,u) -> do
+ Current a' -> do
+ (l,u) <- getBounds a'
a'' <- newArray_ (l,u)
sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]]
return a''
projects / haskell-directory.git / blobdiff