diff --git a/Data/Array.hs b/Data/Array.hs --- a/Data/Array.hs +++ b/Data/Array.hs @@ -26,16 +26,20 @@ module Data.Ix -- export all of Ix , Array -- Array type is abstract + -- * Array construction , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b + -- * Accessing arrays , (!) -- :: (Ix a) => Array a b -> a -> b , bounds -- :: (Ix a) => Array a b -> (a,a) , indices -- :: (Ix a) => Array a b -> [a] , elems -- :: (Ix a) => Array a b -> [b] , assocs -- :: (Ix a) => Array a b -> [(a,b)] + -- * Incremental array updates , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b + -- * Derived arrays , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b -- Array instances: @@ -55,8 +59,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Arr -- Most of the hard work is done here ---import Data.Generics.Instances () -- To provide a Data instance ---import Data.Generics.Basics () -- because the Data instance is an orphan #endif #ifdef __HUGS__ @@ -81,9 +83,5 @@ Since most array functions involve the class 'Ix', this module is exported from "Data.Array" so that modules need not import both "Data.Array" and "Data.Ix". - -Unfortunately, due to technical limitations, there are no docs here -currently, but you can find them in the @GHC.Arr@ module in the @base@ -packages (which provides the actual implementations). -} diff --git a/Data/Array/Base.hs b/Data/Array/Base.hs --- a/Data/Array/Base.hs +++ b/Data/Array/Base.hs @@ -43,8 +43,14 @@ import GHC.Stable ( StablePtr(..) ) import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO ( IO(..), stToIO ) +import GHC.IOArray ( IOArray(..), + newIOArray, unsafeReadIOArray, unsafeWriteIOArray ) +#else import GHC.IOBase ( IO(..), IOArray(..), stToIO, newIOArray, unsafeReadIOArray, unsafeWriteIOArray ) +#endif #else import Data.Int import Data.Word @@ -102,10 +108,11 @@ {-# INLINE safeIndex #-} safeIndex :: Ix i => (i, i) -> Int -> i -> Int -safeIndex (l,u) n i = let i' = unsafeIndex (l,u) i +safeIndex (l,u) n i = let i' = index (l,u) i in if (0 <= i') && (i' < n) then i' - else error "Error in array index" + else error ("Error in array index; " ++ show i' ++ + " not in range [0.." ++ show n ++ ")") {-# INLINE unsafeReplaceST #-} unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e) @@ -352,8 +359,8 @@ 98 requires that for 'Array' the value at such indices is bottom.) For most array types, this operation is O(/n/) where /n/ is the size -of the array. However, the 'Data.Array.Diff.DiffArray' type provides -this operation with complexity linear in the number of updates. +of the array. However, the diffarray package provides an array type +for which this operation has complexity linear in the number of updates. -} (//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e arr // ies = case bounds arr of @@ -956,15 +963,11 @@ unsafeRead :: Ix i => a i e -> Int -> m e unsafeWrite :: Ix i => a i e -> Int -> e -> m () - {-# INLINE newArray #-} + {- INLINE newArray #-} -- The INLINE is crucial, because until we know at least which monad -- we are in, the code below allocates like crazy. So inline it, -- in the hope that the context will know the monad. - newArray (l,u) initialValue = do - let n = safeRangeSize (l,u) - marr <- unsafeNewArray_ (l,u) - sequence_ [unsafeWrite marr i initialValue | i <- [0 .. n - 1]] - return marr + newArray = newArrayImpl {-# INLINE unsafeNewArray_ #-} unsafeNewArray_ (l,u) = newArray (l,u) arrEleBottom @@ -987,6 +990,17 @@ -- default initialisation with undefined values if we *do* know the -- initial value and it is constant for all elements. +-- Workaround for performance bug #3586, GHC 6.12 only (not 6.13 and +-- later, which fixed the underlying problem). +{-# INLINE newArrayImpl #-} +newArrayImpl :: (Ix i, MArray a e m) => (i, i) -> e -> m (a i e) +newArrayImpl (l,u) initialValue = do + let n = safeRangeSize (l,u) + marr <- unsafeNewArray_ (l,u) + sequence_ [unsafeWrite marr i initialValue | i <- [0 .. n - 1]] + return marr + + instance MArray IOArray e IO where #if defined(__HUGS__) getBounds = return . boundsIOArray @@ -1174,7 +1188,7 @@ case loop 0# s2# of { s3# -> (# s3#, STUArray l u n marr# #) }}}} where - W# e# = if initialValue then maxBound else 0 + !(W# e#) = if initialValue then maxBound else 0 {-# INLINE unsafeNewArray_ #-} unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) bOOL_SCALE {-# INLINE newArray_ #-} @@ -1486,12 +1500,12 @@ bOOL_SCALE, bOOL_WORD_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3# - where I# last# = SIZEOF_HSWORD * 8 - 1 + where !(I# last#) = SIZEOF_HSWORD * 8 - 1 bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#) - where I# last# = SIZEOF_HSWORD * 8 - 1 -wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSWORD -dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSDOUBLE -fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSFLOAT + where !(I# last#) = SIZEOF_HSWORD * 8 - 1 +wORD_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSWORD +dOUBLE_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSDOUBLE +fLOAT_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSFLOAT bOOL_INDEX :: Int# -> Int# #if SIZEOF_HSWORD == 4 @@ -1502,8 +1516,9 @@ bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word# bOOL_BIT n# = int2Word# 1# `uncheckedShiftL#` (word2Int# (int2Word# n# `and#` mask#)) - where W# mask# = SIZEOF_HSWORD * 8 - 1 -bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound + where !(W# mask#) = SIZEOF_HSWORD * 8 - 1 +bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# + where !(W# mb#) = maxBound #endif /* __GLASGOW_HASKELL__ */ #ifdef __HUGS__ diff --git a/Data/Array/Diff.hs b/Data/Array/Diff.hs deleted file mode 100644 --- a/Data/Array/Diff.hs +++ /dev/null @@ -1,456 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.Diff --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.IArray) --- --- Functional arrays with constant-time update. --- ------------------------------------------------------------------------------ - -module Data.Array.Diff ( - - -- * Diff array types - - -- | Diff arrays have an immutable interface, but rely on internal - -- updates in place to provide fast functional update operator - -- '//'. - -- - -- When the '//' operator is applied to a diff array, its contents - -- are physically updated in place. The old array silently changes - -- its representation without changing the visible behavior: - -- it stores a link to the new current array along with the - -- difference to be applied to get the old contents. - -- - -- So if a diff array is used in a single-threaded style, - -- i.e. after '//' application the old version is no longer used, - -- @a'!'i@ takes O(1) time and @a '//' d@ takes O(@length d@). - -- Accessing elements of older versions gradually becomes slower. - -- - -- Updating an array which is not current makes a physical copy. - -- The resulting array is unlinked from the old family. So you - -- can obtain a version which is guaranteed to be current and - -- thus have fast element access by @a '//' []@. - - -- Possible improvement for the future (not implemented now): - -- make it possible to say "I will make an update now, but when - -- I later return to the old version, I want it to mutate back - -- instead of being copied". - - IOToDiffArray, -- data IOToDiffArray - -- (a :: * -> * -> *) -- internal mutable array - -- (i :: *) -- indices - -- (e :: *) -- elements - - -- | Type synonyms for the two most important IO array types. - - -- Two most important diff array types are fully polymorphic - -- lazy boxed DiffArray: - DiffArray, -- = IOToDiffArray IOArray - -- ...and strict unboxed DiffUArray, working only for elements - -- of primitive types but more compact and usually faster: - DiffUArray, -- = IOToDiffArray IOUArray - - -- * Overloaded immutable array interface - - -- | Module "Data.Array.IArray" provides the interface of diff arrays. - -- They are instances of class 'IArray'. - module Data.Array.IArray, - - -- * Low-level interface - - -- | These are really internal functions, but you will need them - -- to make further 'IArray' instances of various diff array types - -- (for either more 'MArray' types or more unboxed element types). - newDiffArray, readDiffArray, replaceDiffArray - ) - where - ------------------------------------------------------------------------- --- Imports. - -import Data.Array.Base -import Data.Array.IArray -import Data.Array.IO - -import Foreign.Ptr ( Ptr, FunPtr ) -import Foreign.StablePtr ( StablePtr ) -import Data.Int ( Int8, Int16, Int32, Int64 ) -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 ) - ------------------------------------------------------------------------- --- Diff array types. - --- | An arbitrary 'MArray' type living in the 'IO' monad can be converted --- to a diff array. - -newtype IOToDiffArray a i e = - DiffArray {varDiffArray :: MVar (DiffArrayData a i e)} - --- Internal representation: either a mutable array, or a link to --- another diff array patched with a list of index+element pairs. -data DiffArrayData a i e = Current (a i e) - | Diff (IOToDiffArray a i e) [(Int, e)] - --- | Fully polymorphic lazy boxed diff array. -type DiffArray = IOToDiffArray IOArray - --- | Strict unboxed diff array, working only for elements --- of primitive types but more compact and usually faster than 'DiffArray'. -type DiffUArray = IOToDiffArray IOUArray - --- Having 'MArray a e IO' in instance context would require --- -XUndecidableInstances, so each instance is separate here. - ------------------------------------------------------------------------- --- Showing DiffArrays - -instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Bool) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where - showsPrec = showsIArray - ------------------------------------------------------------------------- --- Boring instances. - -instance IArray (IOToDiffArray IOArray) e where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies - -instance IArray (IOToDiffArray IOUArray) Bool where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Char where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (Ptr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (FunPtr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Float where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Double where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (StablePtr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int8 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int16 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int32 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int64 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word8 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word16 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word32 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word64 where - bounds a = unsafePerformIO $ boundsDiffArray a - numElements a = unsafePerformIO $ numElementsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - - - ------------------------------------------------------------------------- --- The important stuff. - -newDiffArray :: (MArray a e IO, Ix i) - => (i,i) - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -newDiffArray (l,u) ies = do - a <- newArray_ (l,u) - sequence_ [unsafeWrite a i e | (i, e) <- ies] - var <- newMVar (Current a) - return (DiffArray var) - -readDiffArray :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> Int - -> IO e -a `readDiffArray` i = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> unsafeRead a' i - Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies) - -replaceDiffArray :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -a `replaceDiffArray` ies = do - d <- takeMVar (varDiffArray a) - case d of - Current a' -> case ies of - [] -> do - -- We don't do the copy when there is nothing to change - -- and this is the current version. But see below. - putMVar (varDiffArray a) d - return a - _:_ -> do - diff <- sequence [do e <- unsafeRead a' i; return (i, e) - | (i, _) <- ies] - sequence_ [unsafeWrite a' i e | (i, e) <- ies] - var' <- newMVar (Current a') - putMVar (varDiffArray a) (Diff (DiffArray var') diff) - return (DiffArray var') - Diff _ _ -> do - -- We still do the copy when there is nothing to change - -- but this is not the current version. So you can use - -- 'a // []' to make sure that the resulting array has - -- fast element access. - putMVar (varDiffArray a) d - a' <- thawDiffArray a - -- thawDiffArray gives a fresh array which we can - -- safely mutate. - sequence_ [unsafeWrite a' i e | (i, e) <- ies] - var' <- newMVar (Current a') - return (DiffArray var') - --- 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) -arr `replaceDiffArray2` ies = do - mapM_ (\(a,b) -> do evaluate a; evaluate b) ies - arr `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' -> getBounds a' - Diff a' _ -> boundsDiffArray a' - -numElementsDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO Int -numElementsDiffArray a - = do d <- readMVar (varDiffArray a) - case d of - Current a' -> getNumElements a' - Diff a' _ -> numElementsDiffArray a' - -freezeDiffArray :: (MArray a e IO, Ix ix) - => a ix e - -> IO (IOToDiffArray a ix e) -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 - #-} - --- unsafeFreezeDiffArray is really unsafe. Better don't use the old --- array at all after freezing. The contents of the source array will --- be changed when '//' is applied to the resulting array. - -unsafeFreezeDiffArray :: (MArray a e IO, Ix ix) - => a ix e - -> IO (IOToDiffArray a ix e) -unsafeFreezeDiffArray a = do - var <- newMVar (Current a) - return (DiffArray var) - -{-# RULES -"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray - #-} - -thawDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO (a ix e) -thawDiffArray a = do - d <- readMVar (varDiffArray a) - case d of - 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'' - Diff a' ies -> do - a'' <- thawDiffArray a' - sequence_ [unsafeWrite a'' i e | (i, e) <- ies] - return a'' - -{-# RULES -"thaw/DiffArray" thaw = thawDiffArray - #-} - --- unsafeThawDiffArray is really unsafe. Better don't use the old --- array at all after thawing. The contents of the resulting array --- will be changed when '//' is applied to the source array. - -unsafeThawDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO (a ix e) -unsafeThawDiffArray a = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> return a' - Diff a' ies -> do - a'' <- unsafeThawDiffArray a' - sequence_ [unsafeWrite a'' i e | (i, e) <- ies] - return a'' - -{-# RULES -"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray - #-} diff --git a/Data/Array/IArray.hs b/Data/Array/IArray.hs --- a/Data/Array/IArray.hs +++ b/Data/Array/IArray.hs @@ -10,7 +10,8 @@ -- -- Immutable arrays, with an overloaded interface. For array types which -- can be used with this interface, see the 'Array' type exported by this --- module, and the "Data.Array.Unboxed" and "Data.Array.Diff" modules. +-- module and the "Data.Array.Unboxed" module. Other packages, such as +-- diffarray, also provide arrays using this interface. -- ----------------------------------------------------------------------------- diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs --- a/Data/Array/IO.hs +++ b/Data/Array/IO.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -#include "HsBase.h" #-} +{-# OPTIONS_GHC -w #-} --tmp ----------------------------------------------------------------------------- -- | -- Module : Data.Array.IO @@ -32,20 +33,23 @@ import Data.Array.Base import Data.Array.IO.Internals import Data.Array.MArray +import System.IO.Error #ifdef __GLASGOW_HASKELL__ import Foreign import Foreign.C +import GHC.Exts (MutableByteArray#, RealWorld) import GHC.Arr +import GHC.IORef +import GHC.IO.Handle +import GHC.IO.Buffer +import GHC.IO.Exception -import GHC.IOBase -import GHC.Handle #else import Data.Char import Data.Word ( Word8 ) import System.IO -import System.IO.Error #endif #ifdef __GLASGOW_HASKELL__ @@ -64,46 +68,19 @@ -- if the end of file was reached. hGetArray handle (IOUArray (STUArray _l _u n ptr)) count - | count == 0 - = return 0 - | count < 0 || count > n - = illegalBufferSize handle "hGetArray" count + | count == 0 = return 0 + | count < 0 || count > n = illegalBufferSize handle "hGetArray" count | otherwise = do - wantReadableHandle "hGetArray" handle $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref - if bufferEmpty buf - then readChunk fd is_stream ptr 0 count - else do - let avail = w - r - copied <- if (count >= avail) - then do - memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return avail - else do - memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return count - - let remaining = count - copied - if remaining > 0 - then do rest <- readChunk fd is_stream ptr copied remaining - return (rest + copied) - else return count + -- we would like to read directly into the buffer, but we can't + -- be sure that the MutableByteArray# is pinned, so we have to + -- allocate a separate area of memory and copy. + allocaBytes n $ \p -> do + r <- hGetBuf handle p n + memcpy_ba_ptr ptr p (fromIntegral r) + return r -readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int -readChunk fd is_stream ptr init_off bytes0 = loop init_off bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return (off - init_off) - loop off bytes = do - r' <- readRawBuffer "readChunk" (fromIntegral fd) is_stream ptr - (fromIntegral off) (fromIntegral bytes) - let r = fromIntegral r' - if r == 0 - then return (off - init_off) - else loop (off + r) (bytes - r) +foreign import ccall unsafe "memcpy" + memcpy_ba_ptr :: MutableByteArray# RealWorld -> Ptr a -> CSize -> IO (Ptr ()) -- --------------------------------------------------------------------------- -- hPutArray @@ -116,48 +93,26 @@ -> IO () hPutArray handle (IOUArray (STUArray _l _u n raw)) count - | count == 0 - = return () - | count < 0 || count > n - = illegalBufferSize handle "hPutArray" count - | otherwise - = do wantWritableHandle "hPutArray" handle $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do - - old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } - <- readIORef ref - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return () + | count == 0 = return () + | count < 0 || count > n = illegalBufferSize handle "hPutArray" count + | otherwise = do + -- as in hGetArray, we would like to use the array directly, but + -- we can't be sure that the MutableByteArray# is pinned. + allocaBytes n $ \p -> do + memcpy_ptr_ba p raw (fromIntegral n) + hPutBuf handle p n - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd stream old_buf - writeIORef ref flushed_buf - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=count } - flushWriteBuffer fd stream this_buf - return () +foreign import ccall unsafe "memcpy" + memcpy_ptr_ba :: Ptr a -> MutableByteArray# RealWorld -> CSize -> IO (Ptr ()) -- --------------------------------------------------------------------------- -- Internal Utils -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) - illegalBufferSize :: Handle -> String -> Int -> IO a illegalBufferSize handle fn sz = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 (sz::Int) []) - Nothing) + ioException (ioeSetErrorString + (mkIOError InvalidArgument fn (Just handle) Nothing) + ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])) #else /* !__GLASGOW_HASKELL__ */ hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int diff --git a/Data/Array/IO/Internals.hs b/Data/Array/IO/Internals.hs --- a/Data/Array/IO/Internals.hs +++ b/Data/Array/IO/Internals.hs @@ -38,7 +38,11 @@ import Data.Ix #ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IOArray (IOArray(..)) +#else import GHC.IOBase (IOArray(..)) +#endif #endif /* __GLASGOW_HASKELL__ */ #include "Typeable.h" diff --git a/array.cabal b/array.cabal --- a/array.cabal +++ b/array.cabal @@ -1,29 +1,31 @@ name: array -version: 0.2.0.0 +version: 0.3.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29 synopsis: Mutable and immutable arrays category: Data Structures description: This package defines the classes @IArray@ of immutable arrays and @MArray@ of arrays mutable within appropriate monads, as well as some instances of these classes. -cabal-version: >=1.2 +cabal-version: >=1.6 build-type: Simple extra-source-files: include/Typeable.h +source-repository head + type: darcs + location: http://darcs.haskell.org/packages/array/ + library - build-depends: base - if !impl(nhc98) - build-depends: syb + build-depends: base >= 3 && < 5 exposed-modules: Data.Array extensions: CPP if !impl(nhc98) exposed-modules: Data.Array.Base - Data.Array.Diff Data.Array.IArray Data.Array.IO Data.Array.IO.Internals