diff --git a/Data/Array.hs b/Data/Array.hs --- a/Data/Array.hs +++ b/Data/Array.hs @@ -1,10 +1,10 @@ - +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Array +-- Module : Data.Array -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable @@ -16,27 +16,30 @@ -- those defined below, but with more general types, and also defines -- 'Array' instances of the relevant classes. To use that more general -- interface, import "Data.Array.IArray" but not "Data.Array". +-- ----------------------------------------------------------------------------- -module Data.Array - - ( +module Data.Array ( -- * Immutable non-strict arrays -- $intro - module Data.Ix -- export all of Ix - , Array -- Array type is abstract + module Data.Ix, -- export all of Ix + Array, -- Array type is abstract - , 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 - , (!) -- :: (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)] - , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b - , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b - , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b + -- * 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: -- @@ -45,30 +48,13 @@ -- (Ix a, Ord b) => Ord (Array a b) -- (Ix a, Show a, Show b) => Show (Array a b) -- (Ix a, Read a, Read b) => Read (Array a b) - -- + -- -- Implementation checked wrt. Haskell 98 lib report, 1/99. - - ) where + ) where import Data.Ix - -#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__ -import Hugs.Array -#endif - -#ifdef __NHC__ -import Array -- Haskell'98 arrays -#endif - --- For instances: -import Data.Typeable () +import GHC.Arr -- Most of the hard work is done here {- $intro Haskell provides indexable /arrays/, which may be thought of as functions @@ -81,9 +67,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 @@ -1,18 +1,23 @@ -{-# OPTIONS_GHC -XNoBangPatterns -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK hide #-} --- XXX With a GHC 6.9 we get a spurious --- Data/Array/Base.hs:26:0: --- Warning: Module `Data.Ix' is imported, but nothing from it is used, --- except perhaps instances visible in `Data.Ix' --- To suppress this warning, use: import Data.Ix() --- The -fno-warn-unused-imports works around that bug +{-# LANGUAGE + BangPatterns + , CPP + , RankNTypes + , MagicHash + , UnboxedTuples + , MultiParamTypeClasses + , FlexibleInstances + , FlexibleContexts + , UnliftedFFITypes + , RoleAnnotations + #-} +{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Base -- 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 (MPTCs, uses Control.Monad.ST) @@ -20,54 +25,47 @@ -- Basis for IArray and MArray. Not intended for external consumption; -- use IArray or MArray instead. -- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. ----------------------------------------------------------------------------- --- #hide module Data.Array.Base where import Control.Monad.ST.Lazy ( strictToLazyST ) import qualified Control.Monad.ST.Lazy as Lazy (ST) -import Data.Ix ( Ix, range, index, rangeSize ) +import Data.Ix ( Ix, range, index, inRange, rangeSize ) import Foreign.C.Types import Foreign.StablePtr -#ifdef __GLASGOW_HASKELL__ -import GHC.Arr ( STArray, unsafeIndex ) +import Data.Char +import GHC.Arr ( STArray, unsafeIndex ) import qualified GHC.Arr as Arr import qualified GHC.Arr as ArrST -import GHC.ST ( ST(..), runST ) -import GHC.Base -import GHC.Word ( Word(..) ) -import GHC.Ptr ( Ptr(..), FunPtr(..), nullPtr, nullFunPtr ) -import GHC.Float ( Float(..), Double(..) ) -import GHC.Stable ( StablePtr(..) ) -import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) -import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) -import GHC.IOBase ( IO(..), IOArray(..), stToIO, +import GHC.ST ( ST(..), runST ) +import GHC.Base ( IO(..), divInt# ) +import GHC.Exts +import GHC.Ptr ( nullPtr, nullFunPtr ) +import GHC.Show ( appPrec ) +import GHC.Stable ( StablePtr(..) ) +import GHC.Read ( expectP, parens, Read(..) ) +import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) +import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) +import GHC.IO ( stToIO ) +import GHC.IOArray ( IOArray(..), newIOArray, unsafeReadIOArray, unsafeWriteIOArray ) -#else -import Data.Int -import Data.Word -import Foreign.Ptr -#endif - -#ifdef __HUGS__ -import Data.Bits -import Foreign.Storable -import qualified Hugs.Array as Arr -import qualified Hugs.ST as ArrST -import Hugs.Array ( unsafeIndex ) -import Hugs.IOArray -import Hugs.ST ( STArray, ST(..), runST ) -import Hugs.ByteArray -#endif - -import Data.Typeable -#include "Typeable.h" +import Text.Read.Lex ( Lexeme(Ident) ) +import Text.ParserCombinators.ReadPrec ( prec, ReadPrec, step ) -#ifdef __GLASGOW_HASKELL__ #include "MachDeps.h" -#endif ----------------------------------------------------------------------------- -- Class of immutable arrays @@ -102,10 +100,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) @@ -118,24 +117,22 @@ unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e) unsafeAccumST f arr ies = do marr <- thaw arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] return marr {-# INLINE unsafeAccumArrayST #-} unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e) unsafeAccumArrayST f e (l,u) ies = do marr <- newArray (l,u) e - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] return marr -{-# INLINE array #-} +{-# INLINE array #-} {-| Constructs an immutable array from a pair of bounds and a list of initial associations. @@ -171,10 +168,10 @@ gives an array-bounds error, but 'bounds' still yields the bounds with which the array was constructed. -} -array :: (IArray a e, Ix i) - => (i,i) -- ^ bounds of the array: (lowest,highest) - -> [(i, e)] -- ^ list of associations - -> a i e +array :: (IArray a e, Ix i) + => (i,i) -- ^ bounds of the array: (lowest,highest) + -> [(i, e)] -- ^ list of associations + -> a i e array (l,u) ies = let n = safeRangeSize (l,u) in unsafeArray (l,u) @@ -187,7 +184,7 @@ -- fast unsafeFreeze, namely for Array and UArray (well, they cover -- almost all cases). -{-# INLINE listArray #-} +{-# INLINE [1] listArray #-} -- | Constructs an immutable array from a list of initial elements. -- The list gives the elements of the array in ascending order @@ -197,35 +194,26 @@ let n = safeRangeSize (l,u) in unsafeArray (l,u) (zip [0 .. n - 1] es) -{-# INLINE listArrayST #-} +{-# INLINE genArray #-} +-- | Constructs an immutable array using a generator function. +-- +-- @since 0.5.6.0 +genArray :: (IArray a e, Ix i) => (i,i) -> (i -> e) -> a i e +genArray (l,u) f = listArray (l,u) $ map f $ range (l,u) + +{-# INLINE listArrayST #-} -- See Note [Inlining and fusion] listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e) -listArrayST (l,u) es = do - marr <- newArray_ (l,u) - let n = safeRangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es - return marr +listArrayST = newListArray {-# RULES "listArray/Array" listArray = \lu es -> runST (listArrayST lu es >>= ArrST.unsafeFreezeSTArray) #-} -{-# INLINE listUArrayST #-} +{-# INLINE listUArrayST #-} -- See Note [Inlining and fusion] listUArrayST :: (MArray (STUArray s) e (ST s), Ix i) => (i,i) -> [e] -> ST s (STUArray s i e) -listUArrayST (l,u) es = do - marr <- newArray_ (l,u) - let n = safeRangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es - return marr +listUArrayST = newListArray -- I don't know how to write a single rule for listUArrayST, because -- the type looks like constrained over 's', which runST doesn't @@ -234,11 +222,11 @@ -- -- More precisely, we'd like to write this: -- listUArray :: (forall s. MArray (STUArray s) e (ST s), Ix i) --- => (i,i) -> [e] -> UArray i e +-- => (i,i) -> [e] -> UArray i e -- listUArray lu = runST (listUArrayST lu es >>= unsafeFreezeSTUArray) -- {-# RULES listArray = listUArray -- Then we could call listUArray at any type 'e' that had a suitable --- MArray instance. But sadly we can't, because we don't have quantified +-- MArray instance. But sadly we can't, because we don't have quantified -- constraints. Hence the mass of rules below. -- I would like also to write a rule for listUArrayST (or listArray or @@ -246,7 +234,6 @@ -- calls seem to be floated out, then floated back into the middle -- of listUArrayST, so I was not able to do this. -#ifdef __GLASGOW_HASKELL__ type ListUArray e = forall i . Ix i => (i,i) -> [e] -> UArray i e {-# RULES @@ -256,7 +243,7 @@ = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Char "listArray/UArray/Int" listArray = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int -"listArray/UArray/Word" listArray +"listArray/UArray/Word" listArray = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word "listArray/UArray/Ptr" listArray = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (Ptr a) @@ -285,14 +272,25 @@ "listArray/UArray/Word64" listArray = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word64 #-} -#endif {-# INLINE (!) #-} --- | Returns the element of an immutable array at the specified index. +-- | Returns the element of an immutable array at the specified index, +-- or throws an exception if the index is out of bounds. (!) :: (IArray a e, Ix i) => a i e -> i -> e -arr ! i = case bounds arr of +(!) arr i = case bounds arr of (l,u) -> unsafeAt arr $ safeIndex (l,u) (numElements arr) i +{-# INLINE (!?) #-} +-- | Returns 'Just' the element of an immutable array at the specified index, +-- or 'Nothing' if the index is out of bounds. +-- +-- @since 0.5.6.0 +(!?) :: (IArray a e, Ix i) => a i e -> i -> Maybe e +(!?) arr i = let b = bounds arr in + if inRange b i + then Just $ unsafeAt arr $ unsafeIndex b i + else Nothing + {-# INLINE indices #-} -- | Returns a list of all the valid indices in an array. indices :: (IArray a e, Ix i) => a i e -> [i] @@ -302,8 +300,7 @@ -- | Returns a list of all the elements of an array, in the same order -- as their indices. elems :: (IArray a e, Ix i) => a i e -> [e] -elems arr = case bounds arr of - (_l, _u) -> [unsafeAt arr i | i <- [0 .. numElements arr - 1]] +elems arr = [unsafeAt arr i | i <- [0 .. numElements arr - 1]] {-# INLINE assocs #-} -- | Returns the contents of an array as a list of associations. @@ -313,7 +310,7 @@ {-# INLINE accumArray #-} -{-| +{-| Constructs an immutable array from a list of associations. Unlike 'array', the same index is allowed to occur multiple times in the list of associations; an /accumulating function/ is used to combine the @@ -352,8 +349,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 @@ -389,6 +386,94 @@ ixmap (l,u) f arr = array (l,u) [(i, arr ! f i) | i <- range (l,u)] +-- | Lazy right-associative fold. +-- +-- @since 0.5.8.0 +foldrArray :: (IArray a e, Ix i) => (e -> b -> b) -> b -> a i e -> b +foldrArray f z = \a -> + let !n = numElements a + go i | i >= n = z + | otherwise = f (unsafeAt a i) (go (i+1)) + in go 0 +{-# INLINE foldrArray #-} + +-- | Strict accumulating left-associative fold. +-- +-- @since 0.5.8.0 +foldlArray' :: (IArray a e, Ix i) => (b -> e -> b) -> b -> a i e -> b +foldlArray' f z0 = \a -> + let !n = numElements a + go !z i | i >= n = z + | otherwise = go (f z (unsafeAt a i)) (i+1) + in go z0 0 +{-# INLINE foldlArray' #-} + +-- | Lazy left-associative fold. +-- +-- @since 0.5.8.0 +foldlArray :: (IArray a e, Ix i) => (b -> e -> b) -> b -> a i e -> b +foldlArray f z = \a -> + let !n = numElements a + go i | i < 0 = z + | otherwise = f (go (i-1)) (unsafeAt a i) + in go (n-1) +{-# INLINE foldlArray #-} + +-- | Strict accumulating right-associative fold. +-- +-- @since 0.5.8.0 +foldrArray' :: (IArray a e, Ix i) => (e -> b -> b) -> b -> a i e -> b +foldrArray' f z0 = \a -> + let !n = numElements a + go i !z | i < 0 = z + | otherwise = go (i-1) (f (unsafeAt a i) z) + in go (n-1) z0 +{-# INLINE foldrArray' #-} + +-- | Map elements to applicative actions, sequence them left-to-right, and +-- discard the results. +-- +-- @since 0.5.8.0 +traverseArray_ + :: (IArray a e, Ix i, Applicative f) => (e -> f b) -> a i e -> f () +traverseArray_ f = foldrArray (\x z -> f x *> z) (pure ()) +{-# INLINE traverseArray_ #-} + +-- | @forArray_@ is 'traverseArray_' with its arguments flipped. +-- +-- @since 0.5.8.0 +forArray_ :: (IArray a e, Ix i, Applicative f) => a i e -> (e -> f b) -> f () +forArray_ = flip traverseArray_ +{-# INLINE forArray_ #-} + +-- | Strict accumulating left-associative monadic fold. +-- +-- @since 0.5.8.0 +foldlArrayM' + :: (IArray a e, Ix i, Monad m) => (b -> e -> m b) -> b -> a i e -> m b +foldlArrayM' f z0 = \a -> + let !n = numElements a + go !z i | i >= n = pure z + | otherwise = do + z' <- f z (unsafeAt a i) + go z' (i+1) + in go z0 0 +{-# INLINE foldlArrayM' #-} + +-- | Strict accumulating right-associative monadic fold. +-- +-- @since 0.5.8.0 +foldrArrayM' + :: (IArray a e, Ix i, Monad m) => (e -> b -> m b) -> b -> a i e -> m b +foldrArrayM' f z0 = \a -> + let !n = numElements a + go i !z | i < 0 = pure z + | otherwise = do + z' <- f (unsafeAt a i) z + go (i-1) z' + in go (n-1) z0 +{-# INLINE foldrArrayM' #-} + ----------------------------------------------------------------------------- -- Normal polymorphic arrays @@ -427,14 +512,9 @@ -- get the benefits of unboxed arrays (don\'t forget to import -- "Data.Array.Unboxed" instead of "Data.Array"). -- -#ifdef __GLASGOW_HASKELL__ data UArray i e = UArray !i !i !Int ByteArray# -#endif -#ifdef __HUGS__ -data UArray i e = UArray !i !i !Int !ByteArray -#endif - -INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray") +-- There are class-based invariants on both parameters. See also #9220. +type role UArray nominal nominal {-# INLINE unsafeArrayUArray #-} unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) @@ -446,15 +526,9 @@ {-# INLINE unsafeFreezeSTUArray #-} unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e) -#if __GLASGOW_HASKELL__ unsafeFreezeSTUArray (STUArray l u n marr#) = ST $ \s1# -> case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) -> (# s2#, UArray l u n arr# #) } -#elif __HUGS__ -unsafeFreezeSTUArray (STUArray l u n marr) = do - arr <- unsafeFreezeMutableByteArray marr - return (UArray l u n arr) -#endif {-# INLINE unsafeReplaceUArray #-} unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i) @@ -469,10 +543,9 @@ => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e) unsafeAccumUArray f arr ies = do marr <- thawSTUArray arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] unsafeFreezeSTUArray marr {-# INLINE unsafeAccumArrayUArray #-} @@ -480,10 +553,9 @@ => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e) unsafeAccumArrayUArray f initialValue (l,u) ies = do marr <- newArray (l,u) initialValue - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] unsafeFreezeSTUArray marr {-# INLINE eqUArray #-} @@ -493,7 +565,7 @@ l1 == l2 && u1 == u2 && and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]] -{-# INLINE cmpUArray #-} +{-# INLINE [1] cmpUArray #-} cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2) @@ -513,29 +585,36 @@ {-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-} ----------------------------------------------------------------------------- --- Showing IArrays +-- Showing and Reading IArrays -{-# SPECIALISE - showsIArray :: (IArray UArray e, Ix i, Show i, Show e) => - Int -> UArray i e -> ShowS +{-# SPECIALISE + showsIArray :: (IArray UArray e, Ix i, Show i, Show e) => + Int -> UArray i e -> ShowS #-} showsIArray :: (IArray a e, Ix i, Show i, Show e) => Int -> a i e -> ShowS showsIArray p a = - showParen (p > 9) $ + showParen (p > appPrec) $ showString "array " . shows (bounds a) . showChar ' ' . shows (assocs a) +{-# SPECIALISE + readIArray :: (IArray UArray e, Ix i, Read i, Read e) => + ReadPrec (UArray i e) + #-} + +readIArray :: (IArray a e, Ix i, Read i, Read e) => ReadPrec (a i e) +readIArray = parens $ prec appPrec $ + do expectP (Ident "array") + theBounds <- step readPrec + vals <- step readPrec + return (array theBounds vals) + ----------------------------------------------------------------------------- -- Flat unboxed arrays: instances -#ifdef __HUGS__ -unsafeAtBArray :: Storable e => UArray i e -> Int -> e -unsafeAtBArray (UArray _ _ _ arr) = readByteArray arr -#endif - instance IArray UArray Bool where {-# INLINE bounds #-} bounds (UArray l u _ _) = (l,u) @@ -543,16 +622,11 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies False) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ _ arr#) (I# i#) = - (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#) - `neWord#` int2Word# 0# -#endif -#ifdef __HUGS__ - unsafeAt (UArray _ _ _ arr) i = - testBit (readByteArray arr (bOOL_INDEX i)::BitSet) (bOOL_SUBINDEX i) -#endif + unsafeAt (UArray _ _ _ arr#) (I# i#) = isTrue# + ((indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#) + `neWord#` int2Word# 0#) + {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -568,12 +642,7 @@ {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies '\0') {-# INLINE unsafeAt #-} -#ifdef __GLASGOW_HASKELL__ unsafeAt (UArray _ _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -588,13 +657,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -609,13 +673,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -631,12 +690,7 @@ {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullPtr) {-# INLINE unsafeAt #-} -#ifdef __GLASGOW_HASKELL__ unsafeAt (UArray _ _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -651,13 +705,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullFunPtr) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -672,13 +721,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -693,13 +737,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -714,13 +753,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullStablePtr) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -730,12 +764,7 @@ -- bogus StablePtr value for initialising a UArray of StablePtr. nullStablePtr :: StablePtr a -#ifdef __GLASGOW_HASKELL__ -nullStablePtr = StablePtr (unsafeCoerce# 0#) -#endif -#ifdef __HUGS__ -nullStablePtr = castPtrToStablePtr nullPtr -#endif +nullStablePtr = StablePtr (unsafeCoerce# nullAddr#) instance IArray UArray Int8 where {-# INLINE bounds #-} @@ -744,13 +773,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -765,13 +789,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -786,13 +805,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -807,13 +821,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -828,13 +837,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -849,13 +853,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -870,13 +869,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -891,13 +885,8 @@ numElements (UArray _ _ n _) = n {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeAt #-} unsafeAt (UArray _ _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} @@ -914,6 +903,9 @@ instance (Ix ix, Show ix, Show e, IArray UArray e) => Show (UArray ix e) where showsPrec = showsIArray +instance (Ix ix, Read ix, Read e, IArray UArray e) => Read (UArray ix e) where + readPrec = readIArray + ----------------------------------------------------------------------------- -- Mutable arrays @@ -933,33 +925,36 @@ in which the mutable array will be manipulated. -} class (Monad m) => MArray a e m where - - -- | Returns the bounds of the array + -- | Returns the bounds of the array (lowest,highest). getBounds :: Ix i => a i e -> m (i,i) - -- | Returns the number of elements in the array + -- | Returns the number of elements in the array. getNumElements :: Ix i => a i e -> m Int - -- | Builds a new array, with every element initialised to the supplied - -- value. + -- | Builds a new array, with every element initialised to the supplied + -- value. The first and second element of the tuple specifies the lowest + -- and highest index, respectively. newArray :: Ix i => (i,i) -> e -> m (a i e) -- | Builds a new array, with every element initialised to an -- undefined value. In a monadic context in which operations must -- be deterministic (e.g. the ST monad), the array elements are -- initialised to a fixed but undefined value, such as zero. + -- The first and second element of the tuple specifies the lowest + -- and highest index, respectively. newArray_ :: Ix i => (i,i) -> m (a i e) -- | Builds a new array, with every element initialised to an undefined - -- value. + -- value. The first and second element of the tuple specifies the lowest + -- and highest index, respectively. unsafeNewArray_ :: Ix i => (i,i) -> m (a i e) unsafeRead :: Ix i => a i e -> Int -> m e unsafeWrite :: Ix i => a i e -> Int -> e -> m () {-# 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. + -- 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) @@ -987,35 +982,52 @@ -- default initialisation with undefined values if we *do* know the -- initial value and it is constant for all elements. + {-# MINIMAL getBounds, getNumElements, (newArray | unsafeNewArray_), unsafeRead, unsafeWrite #-} + instance MArray IOArray e IO where -#if defined(__HUGS__) - getBounds = return . boundsIOArray - getNumElements = return . getNumElementsIOArray -#elif defined(__GLASGOW_HASKELL__) {-# INLINE getBounds #-} getBounds (IOArray marr) = stToIO $ getBounds marr {-# INLINE getNumElements #-} getNumElements (IOArray marr) = stToIO $ getNumElements marr -#endif newArray = newIOArray unsafeRead = unsafeReadIOArray unsafeWrite = unsafeWriteIOArray -{-# INLINE newListArray #-} +{-# INLINE newListArray #-} -- See Note [Inlining and fusion] -- | Constructs a mutable array from a list of initial elements. -- The list gives the elements of the array in ascending order --- beginning with the lowest index. +-- beginning with the lowest index. The first and second element +-- of the tuple specifies the lowest and highest index, respectively. newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) newListArray (l,u) es = do marr <- newArray_ (l,u) let n = safeRangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es + f x k i + | i == n = return () + | otherwise = unsafeWrite marr i x >> k (i+1) + foldr f (\ !_i -> return ()) es 0 + -- The bang above is important for GHC for unbox the Int. return marr +{-# INLINE newGenArray #-} +-- | Constructs a mutable array using a generator function. +-- It invokes the generator function in ascending order of the indices. +-- +-- @since 0.5.6.0 +newGenArray :: (MArray a e m, Ix i) => (i,i) -> (i -> m e) -> m (a i e) +newGenArray bnds f = do + let n = safeRangeSize bnds + marr <- unsafeNewArray_ bnds + let g ix k i + | i == n = return () + | otherwise = do + x <- f ix + unsafeWrite marr i x + k (i+1) + foldr g (\ !_i -> return ()) (range bnds) 0 + -- The bang above is important for GHC for unbox the Int. + return marr + {-# INLINE readArray #-} -- | Read an element from a mutable array readArray :: (MArray a e m, Ix i) => a i e -> i -> m e @@ -1032,10 +1044,35 @@ n <- getNumElements marr unsafeWrite marr (safeIndex (l,u) n i) e +{-# INLINE modifyArray #-} +-- | Modify an element in a mutable array +-- +-- @since 0.5.6.0 +modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m () +modifyArray marr i f = do + (l,u) <- getBounds marr + n <- getNumElements marr + let idx = safeIndex (l,u) n i + x <- unsafeRead marr idx + unsafeWrite marr idx (f x) + +{-# INLINE modifyArray' #-} +-- | Modify an element in a mutable array. Strict in the written element. +-- +-- @since 0.5.6.0 +modifyArray' :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m () +modifyArray' marr i f = do + (l,u) <- getBounds marr + n <- getNumElements marr + let idx = safeIndex (l,u) n i + x <- unsafeRead marr idx + let !x' = f x + unsafeWrite marr idx x' + {-# INLINE getElems #-} -- | Return a list of all the elements of a mutable array getElems :: (MArray a e m, Ix i) => a i e -> m [e] -getElems marr = do +getElems marr = do (_l, _u) <- getBounds marr n <- getNumElements marr sequence [unsafeRead marr i | i <- [0 .. n - 1]] @@ -1044,7 +1081,7 @@ -- | Return a list of all the associations of a mutable array, in -- index order. getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)] -getAssocs marr = do +getAssocs marr = do (l,u) <- getBounds marr n <- getNumElements marr sequence [ do e <- unsafeRead marr (safeIndex (l,u) n i); return (i,e) @@ -1054,14 +1091,13 @@ -- | Constructs a new array derived from the original array by applying a -- function to each of the elements. mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) -mapArray f marr = do +mapArray f marr = do (l,u) <- getBounds marr n <- getNumElements marr marr' <- newArray_ (l,u) - sequence_ [do - e <- unsafeRead marr i - unsafeWrite marr' i (f e) - | i <- [0 .. n - 1]] + sequence_ [do e <- unsafeRead marr i + unsafeWrite marr' i (f e) + | i <- [0 .. n - 1]] return marr' {-# INLINE mapIndices #-} @@ -1071,12 +1107,75 @@ mapIndices (l',u') f marr = do marr' <- newArray_ (l',u') n' <- getNumElements marr' - sequence_ [do - e <- readArray marr (f i') - unsafeWrite marr' (safeIndex (l',u') n' i') e - | i' <- range (l',u')] + sequence_ [do e <- readArray marr (f i') + unsafeWrite marr' (safeIndex (l',u') n' i') e + | i' <- range (l',u')] return marr' +-- | Strict accumulating left-associative fold. +-- +-- @since 0.5.8.0 +foldlMArray' :: (MArray a e m, Ix i) => (b -> e -> b) -> b -> a i e -> m b +foldlMArray' f = foldlMArrayM' (\z x -> pure (f z x)) +{-# INLINE foldlMArray' #-} + +-- | Strict accumulating right-associative fold. +-- +-- @since 0.5.8.0 +foldrMArray' :: (MArray a e m, Ix i) => (e -> b -> b) -> b -> a i e -> m b +foldrMArray' f = foldrMArrayM' (\x z -> pure (f x z)) +{-# INLINE foldrMArray' #-} + +-- | Strict accumulating left-associative monadic fold. +-- +-- @since 0.5.8.0 +foldlMArrayM' :: (MArray a e m, Ix i) => (b -> e -> m b) -> b -> a i e -> m b +foldlMArrayM' f z0 = \a -> do + !n <- getNumElements a + let go !z i | i >= n = pure z + | otherwise = do + x <- unsafeRead a i + z' <- f z x + go z' (i+1) + go z0 0 +{-# INLINE foldlMArrayM' #-} + +-- | Strict accumulating right-associative monadic fold. +-- +-- @since 0.5.8.0 +foldrMArrayM' :: (MArray a e m, Ix i) => (e -> b -> m b) -> b -> a i e -> m b +foldrMArrayM' f z0 = \a -> do + !n <- getNumElements a + let go i !z | i < 0 = pure z + | otherwise = do + x <- unsafeRead a i + z' <- f x z + go (i-1) z' + go (n-1) z0 +{-# INLINE foldrMArrayM' #-} + +-- | Map elements to monadic actions, sequence them left-to-right, and discard +-- the results. +-- +-- @since 0.5.8.0 +mapMArrayM_ :: (MArray a e m, Ix i) => (e -> m b) -> a i e -> m () +mapMArrayM_ f = \a -> do + !n <- getNumElements a + let go i | i >= n = pure () + | otherwise = do + x <- unsafeRead a i + _ <- f x + go (i+1) + go 0 +{-# INLINE mapMArrayM_ #-} + +-- | @forMArrayM_@ is 'mapMArrayM_' with its arguments flipped. +-- +-- @since 0.5.8.0 +forMArrayM_ :: (MArray a e m, Ix i) => a i e -> (e -> m b) -> m () +forMArrayM_ = flip mapMArrayM_ +{-# INLINE forMArrayM_ #-} + ----------------------------------------------------------------------------- -- Polymorphic non-strict mutable arrays (ST monad) @@ -1104,10 +1203,6 @@ {-# INLINE unsafeWrite #-} unsafeWrite arr i e = strictToLazyST (ArrST.unsafeWriteSTArray arr i e) -#ifdef __HUGS__ -INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") -#endif - ----------------------------------------------------------------------------- -- Flat unboxed mutable arrays (ST monad) @@ -1126,26 +1221,15 @@ -- element type. However, 'STUArray' is strict in its elements - so -- don\'t use 'STUArray' if you require the non-strictness that -- 'STArray' provides. -#ifdef __GLASGOW_HASKELL__ data STUArray s i e = STUArray !i !i !Int (MutableByteArray# s) -#endif -#ifdef __HUGS__ -data STUArray s i e = STUArray !i !i !Int !(MutableByteArray s) -#endif - -INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray") +-- The "ST" parameter must be nominal for the safety of the ST trick. +-- The other parameters have class constraints. See also #9220. +type role STUArray nominal nominal nominal -#ifdef __GLASGOW_HASKELL__ instance Eq (STUArray s i e) where STUArray _ _ _ arr1# == STUArray _ _ _ arr2# = - sameMutableByteArray# arr1# arr2# -#endif -#ifdef __HUGS__ -instance Eq (STUArray s i e) where - STUArray _ _ _ arr1 == STUArray _ _ _ arr2 = arr1 == arr2 -#endif + isTrue# (sameMutableByteArray# arr1# arr2#) -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeNewArraySTUArray_ #-} unsafeNewArraySTUArray_ :: Ix i => (i,i) -> (Int# -> Int#) -> ST s (STUArray s i e) @@ -1164,17 +1248,13 @@ getNumElements (STUArray _ _ n _) = return n {-# INLINE newArray #-} newArray (l,u) initialValue = ST $ \s1# -> - case safeRangeSize (l,u) of { n@(I# n#) -> - case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> - case bOOL_WORD_SCALE n# of { n'# -> - let loop i# s3# | i# ==# n'# = s3# - | otherwise = - case writeWordArray# marr# i# e# s3# of { s4# -> - loop (i# +# 1#) s4# } in - case loop 0# s2# of { s3# -> + case safeRangeSize (l,u) of { n@(I# n#) -> + case bOOL_SCALE n# of { nbytes# -> + case newByteArray# nbytes# s1# of { (# s2#, marr# #) -> + case setByteArray# marr# 0# nbytes# e# s2# of { s3# -> (# s3#, STUArray l u n marr# #) }}}} where - W# e# = if initialValue then maxBound else 0 + !(I# e#) = if initialValue then 0xff else 0x0 {-# INLINE unsafeNewArray_ #-} unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) bOOL_SCALE {-# INLINE newArray_ #-} @@ -1182,7 +1262,7 @@ {-# INLINE unsafeRead #-} unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) -> - (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) } + (# s2#, isTrue# ((e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0#) :: Bool #) } {-# INLINE unsafeWrite #-} unsafeWrite (STUArray _ _ _ marr#) (I# i#) e = ST $ \s1# -> case bOOL_INDEX i# of { j# -> @@ -1198,7 +1278,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds (chr 0) {-# INLINE unsafeRead #-} @@ -1360,7 +1440,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 2#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 2#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1378,7 +1458,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1396,11 +1476,11 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 8#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 8#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> + unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> case readInt64Array# marr# i# s1# of { (# s2#, e# #) -> (# s2#, I64# e# #) } {-# INLINE unsafeWrite #-} @@ -1432,7 +1512,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 2#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 2#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1450,7 +1530,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1468,7 +1548,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 8#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 8#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1483,16 +1563,33 @@ ----------------------------------------------------------------------------- -- Translation between elements and bytes -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 -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 +bOOL_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# +bOOL_SCALE n# = + -- Round the number of bits up to the next whole-word-aligned number + -- of bytes to avoid ghc#23132; the addition can signed-overflow but + -- that's OK because it will not unsigned-overflow and the logical + -- right-shift brings us back in-bounds +#if SIZEOF_HSWORD == 4 + ((n# +# 31#) `uncheckedIShiftRL#` 5#) `uncheckedIShiftL#` 2# +#elif SIZEOF_HSWORD == 8 + ((n# +# 63#) `uncheckedIShiftRL#` 6#) `uncheckedIShiftL#` 3# +#endif +wORD_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSWORD +dOUBLE_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSDOUBLE +fLOAT_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSFLOAT +safe_scale :: Int# -> Int# -> Int# +safe_scale scale# n# + | not overflow = res# + | otherwise = error $ "Data.Array.Base.safe_scale: Overflow; scale: " + ++ show (I# scale#) ++ ", n: " ++ show (I# n#) + where + !res# = scale# *# n# + !overflow = isTrue# (maxN# `divInt#` scale# <# n#) + !(I# maxN#) = maxBound +{-# INLINE safe_scale #-} + +-- | The index of the word which the given @Bool@ array elements falls within. bOOL_INDEX :: Int# -> Int# #if SIZEOF_HSWORD == 4 bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5# @@ -1502,193 +1599,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 -#endif /* __GLASGOW_HASKELL__ */ - -#ifdef __HUGS__ -newMBArray_ :: (Ix i, Storable e) => (i,i) -> ST s (STUArray s i e) -newMBArray_ = makeArray undefined - where - makeArray :: (Ix i, Storable e) => e -> (i,i) -> ST s (STUArray s i e) - makeArray dummy (l,u) = do - let n = safeRangeSize (l,u) - marr <- newMutableByteArray (n * sizeOf dummy) - return (STUArray l u n marr) - -unsafeReadMBArray :: Storable e => STUArray s i e -> Int -> ST s e -unsafeReadMBArray (STUArray _ _ _ marr) = readMutableByteArray marr - -unsafeWriteMBArray :: Storable e => STUArray s i e -> Int -> e -> ST s () -unsafeWriteMBArray (STUArray _ _ _ marr) = writeMutableByteArray marr - -getBoundsMBArray :: Storable e => STUArray s i e -> ST s (i, i) -getBoundsMBArray (STUArray l u _ _) = return (l,u) - -getNumElementsMBArray :: Storable e => STUArray s i e -> ST s Int -getNumElementsMBArray (STUArray _ _ n _) = return n - -instance MArray (STUArray s) Bool (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ (l,u) = do - let n = rangeSize (l,u) - marr <- newMutableByteArray (bOOL_SCALE n) - return (STUArray l u n marr) - newArray_ bounds = unsafeNewArray_ bounds - unsafeRead (STUArray _ _ _ marr) i = do - let ix = bOOL_INDEX i - bit = bOOL_SUBINDEX i - w <- readMutableByteArray marr ix - return (testBit (w::BitSet) bit) - unsafeWrite (STUArray _ _ _ marr) i e = do - let ix = bOOL_INDEX i - bit = bOOL_SUBINDEX i - w <- readMutableByteArray marr ix - writeMutableByteArray marr ix - (if e then setBit (w::BitSet) bit else clearBit w bit) - -instance MArray (STUArray s) Char (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (Ptr a) (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (FunPtr a) (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Float (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Double (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (StablePtr a) (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int8 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int16 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int32 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int64 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word8 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word16 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word32 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word64 (ST s) where - getBounds = getBoundsMBArray - getNumElements = getNumElementsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -type BitSet = Word8 - -bitSetSize = bitSize (0::BitSet) - -bOOL_SCALE :: Int -> Int -bOOL_SCALE n = (n + bitSetSize - 1) `div` bitSetSize - -bOOL_INDEX :: Int -> Int -bOOL_INDEX i = i `div` bitSetSize - -bOOL_SUBINDEX :: Int -> Int -bOOL_SUBINDEX i = i `mod` bitSetSize -#endif /* __HUGS__ */ + where !(W# mask#) = SIZEOF_HSWORD * 8 - 1 +bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# + where !(W# mb#) = maxBound ----------------------------------------------------------------------------- -- Freezing @@ -1697,6 +1610,7 @@ -- immutable array (any instance of 'IArray') by taking a complete -- copy of it. freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) +{-# NOINLINE [1] freeze #-} freeze marr = do (l,u) <- getBounds marr n <- getNumElements marr @@ -1705,15 +1619,14 @@ -- use the safe array creation function here. return (listArray (l,u) es) -#ifdef __GLASGOW_HASKELL__ -freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e) +freezeSTUArray :: STUArray s i e -> ST s (UArray i e) freezeSTUArray (STUArray l u n marr#) = ST $ \s1# -> - case sizeofMutableByteArray# marr# of { n# -> - case newByteArray# n# s1# of { (# s2#, marr'# #) -> + case getSizeofMutableByteArray# marr# s1# of { (# s2#, n# #) -> + case newByteArray# n# s2# of { (# s3#, marr'# #) -> case memcpy_freeze marr'# marr# (fromIntegral (I# n#)) of { IO m -> - case unsafeCoerce# m s2# of { (# s3#, _ #) -> - case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) -> - (# s4#, UArray l u n arr# #) }}}}} + case unsafeCoerce# m s3# of { (# s4#, _ #) -> + case unsafeFreezeByteArray# marr'# s4# of { (# s5#, arr# #) -> + (# s5#, UArray l u n arr# #) }}}}} foreign import ccall unsafe "memcpy" memcpy_freeze :: MutableByteArray# s -> MutableByteArray# s -> CSize @@ -1723,7 +1636,6 @@ "freeze/STArray" freeze = ArrST.freezeSTArray "freeze/STUArray" freeze = freezeSTUArray #-} -#endif /* __GLASGOW_HASKELL__ */ -- In-place conversion of mutable arrays to immutable ones places -- a proof obligation on the user: no other parts of your code can @@ -1731,7 +1643,7 @@ -- freeze it (and, subsequently mutate it, I suspect). {- | - Converts an mutable array into an immutable array. The + Converts an mutable array into an immutable array. The implementation may either simply cast the array from one type to the other without copying the array, or it may take a full copy of the array. @@ -1757,7 +1669,7 @@ * 'Data.Array.ST.STArray' -> 'Data.Array.Array' -} -{-# INLINE unsafeFreeze #-} +{-# INLINE [1] unsafeFreeze #-} unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) unsafeFreeze = freeze @@ -1773,6 +1685,7 @@ -- mutable array (any instance of 'MArray') by taking a complete copy -- of it. thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) +{-# NOINLINE [1] thaw #-} thaw arr = case bounds arr of (l,u) -> do marr <- newArray_ (l,u) @@ -1781,8 +1694,7 @@ | i <- [0 .. n - 1]] return marr -thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) -#if __GLASGOW_HASKELL__ +thawSTUArray :: UArray i e -> ST s (STUArray s i e) thawSTUArray (UArray l u n arr#) = ST $ \s1# -> case sizeofByteArray# arr# of { n# -> case newByteArray# n# s1# of { (# s2#, marr# #) -> @@ -1798,11 +1710,6 @@ "thaw/STArray" thaw = ArrST.thawSTArray "thaw/STUArray" thaw = thawSTUArray #-} -#elif __HUGS__ -thawSTUArray (UArray l u n arr) = do - marr <- thawByteArray arr - return (STUArray l u n marr) -#endif -- In-place conversion of immutable arrays to mutable ones places -- a proof obligation on the user: no other parts of your code can @@ -1810,10 +1717,10 @@ -- thaw it (and, subsequently mutate it, I suspect). {- | - Converts an immutable array into a mutable array. The + Converts an immutable array into a mutable array. The implementation may either simply cast the array from one type to the other without copying the array, or it - may take a full copy of the array. + may take a full copy of the array. Note that because the array is possibly not copied, any subsequent modifications made to the mutable version of the array may be @@ -1842,13 +1749,12 @@ * 'Data.Array.Array' -> 'Data.Array.ST.STArray' -} -{-# INLINE unsafeThaw #-} +{-# INLINE [1] unsafeThaw #-} unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) unsafeThaw = thaw -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeThawSTUArray #-} -unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) +unsafeThawSTUArray :: UArray i e -> ST s (STUArray s i e) unsafeThawSTUArray (UArray l u n marr#) = return (STUArray l u n (unsafeCoerce# marr#)) @@ -1858,7 +1764,7 @@ #-} {-# INLINE unsafeThawIOArray #-} -unsafeThawIOArray :: Ix ix => Arr.Array ix e -> IO (IOArray ix e) +unsafeThawIOArray :: Arr.Array ix e -> IO (IOArray ix e) unsafeThawIOArray arr = stToIO $ do marr <- ArrST.unsafeThawSTArray arr return (IOArray marr) @@ -1867,7 +1773,7 @@ "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray #-} -thawIOArray :: Ix ix => Arr.Array ix e -> IO (IOArray ix e) +thawIOArray :: Arr.Array ix e -> IO (IOArray ix e) thawIOArray arr = stToIO $ do marr <- ArrST.thawSTArray arr return (IOArray marr) @@ -1876,7 +1782,7 @@ "thaw/IOArray" thaw = thawIOArray #-} -freezeIOArray :: Ix ix => IOArray ix e -> IO (Arr.Array ix e) +freezeIOArray :: IOArray ix e -> IO (Arr.Array ix e) freezeIOArray (IOArray marr) = stToIO (ArrST.freezeSTArray marr) {-# RULES @@ -1884,21 +1790,26 @@ #-} {-# INLINE unsafeFreezeIOArray #-} -unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Arr.Array ix e) +unsafeFreezeIOArray :: IOArray ix e -> IO (Arr.Array ix e) unsafeFreezeIOArray (IOArray marr) = stToIO (ArrST.unsafeFreezeSTArray marr) {-# RULES "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray #-} -#endif /* __GLASGOW_HASKELL__ */ -- | Casts an 'STUArray' with one element type into one with a -- different element type. All the elements of the resulting array -- are undefined (unless you know what you\'re doing...). castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b) -#if __GLASGOW_HASKELL__ castSTUArray (STUArray l u n marr#) = return (STUArray l u n marr#) -#elif __HUGS__ -castSTUArray (STUArray l u n marr) = return (STUArray l u n marr) -#endif + +-------------------------------------------------------------------------------- + +-- Note [Inlining and fusion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Many functions in this module are marked INLINE because they consume their +-- input with `foldr`. By inlining them, it is possible that the `foldr` will +-- meet a `build` from the call site, and beneficial fusion will take place. +-- That is, they become "good consumers". See array issue #8 for data showing +-- the perf improvement that comes with fusion. 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 @@ -1,40 +1,54 @@ +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.IArray -- 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.Base) -- -- 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. -- ----------------------------------------------------------------------------- -module Data.Array.IArray ( +module Data.Array.IArray ( -- * Array classes IArray, -- :: (* -> * -> *) -> * -> class module Data.Ix, -- * Immutable non-strict (boxed) arrays - Array, + Array, -- * Array construction array, -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e listArray, -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e + genArray, -- :: (IArray a e, Ix i) => (i,i) -> (i -> e) -> a i e -- * Accessing arrays (!), -- :: (IArray a e, Ix i) => a i e -> i -> e + (!?), -- :: (IArray a e, Ix i) => a i e -> i -> Maybe e bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i) indices, -- :: (HasBounds a, Ix i) => a i e -> [i] elems, -- :: (IArray a e, Ix i) => a i e -> [e] assocs, -- :: (IArray a e, Ix i) => a i e -> [(i, e)] + -- * Array folds + foldrArray, + foldlArray', + foldlArray, + foldrArray', + traverseArray_, + forArray_, + foldlArrayM', + foldrArrayM', + -- * Incremental array updates (//), -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e accum, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e @@ -42,8 +56,9 @@ -- * Derived arrays amap, -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e ixmap, -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e - ) where + ) where import Data.Ix import Data.Array (Array) import Data.Array.Base + diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs --- a/Data/Array/IO.hs +++ b/Data/Array/IO.hs @@ -1,10 +1,11 @@ -{-# OPTIONS_GHC -#include "HsBase.h" #-} +{-# LANGUAGE MagicHash, Trustworthy, UnliftedFFITypes #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Array.IO -- 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.MArray) @@ -14,184 +15,89 @@ ----------------------------------------------------------------------------- module Data.Array.IO ( - -- * @IO@ arrays with boxed elements - IOArray, -- instance of: Eq, Typeable + -- * @IO@ arrays with boxed elements + IOArray, -- instance of: Eq, Typeable - -- * @IO@ arrays with unboxed elements - IOUArray, -- instance of: Eq, Typeable - castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b) + -- * @IO@ arrays with unboxed elements + IOUArray, -- instance of: Eq, Typeable - -- * Overloaded mutable array interface - module Data.Array.MArray, + -- * Overloaded mutable array interface + module Data.Array.MArray, - -- * Doing I\/O with @IOUArray@s - hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int - hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO () - ) where + -- * Doing I\/O with @IOUArray@s + hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int + hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO () + ) where 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.Arr - -import GHC.IOBase -import GHC.Handle -#else -import Data.Char -import Data.Word ( Word8 ) -import System.IO -import System.IO.Error -#endif +import GHC.Exts (MutableByteArray#, RealWorld) +import GHC.IO.Handle +import GHC.IO.Exception -#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- hGetArray -- | Reads a number of 'Word8's from the specified 'Handle' directly -- into an array. hGetArray - :: Handle -- ^ Handle to read from - -> IOUArray Int Word8 -- ^ Array in which to place the values - -> Int -- ^ Number of 'Word8's to read - -> IO Int - -- ^ Returns: the number of 'Word8's actually - -- read, which might be smaller than the number requested - -- if the end of file was reached. + :: Handle -- ^ Handle to read from + -> IOUArray Int Word8 -- ^ Array in which to place the values + -> Int -- ^ Number of 'Word8's to read + -> IO Int + -- ^ Returns: the number of 'Word8's actually + -- read, which might be smaller than the number requested + -- 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 count $ \p -> do + r <- hGetBuf handle p count + _ <- 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 -- | Writes an array of 'Word8' to the specified 'Handle'. hPutArray - :: Handle -- ^ Handle to write to - -> IOUArray Int Word8 -- ^ Array to write from - -> Int -- ^ Number of 'Word8's to write - -> IO () + :: Handle -- ^ Handle to write to + -> IOUArray Int Word8 -- ^ Array to write from + -> Int -- ^ Number of 'Word8's to write + -> 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 count $ \p -> do + _ <- memcpy_ptr_ba p raw (fromIntegral count) + hPutBuf handle p count - -- 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) - -#else /* !__GLASGOW_HASKELL__ */ -hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int -hGetArray handle arr count = do - bds <- getBounds arr - if count < 0 || count > rangeSize bds - then illegalBufferSize handle "hGetArray" count - else get 0 - where - get i | i == count = return i - | otherwise = do - error_or_c <- try (hGetChar handle) - case error_or_c of - Left ex - | isEOFError ex -> return i - | otherwise -> ioError ex - Right c -> do - unsafeWrite arr i (fromIntegral (ord c)) - get (i+1) - -hPutArray :: Handle -> IOUArray Int Word8 -> Int -> IO () -hPutArray handle arr count = do - bds <- getBounds arr - if count < 0 || count > rangeSize bds - then illegalBufferSize handle "hPutArray" count - else put 0 - where - put i | i == count = return () - | otherwise = do - w <- unsafeRead arr i - hPutChar handle (chr (fromIntegral w)) - put (i+1) - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize _ fn sz = ioError $ - userError (fn ++ ": illegal buffer size " ++ showsPrec 9 (sz::Int) []) -#endif /* !__GLASGOW_HASKELL__ */ +illegalBufferSize handle fn sz = + ioException (ioeSetErrorString + (mkIOError InvalidArgument fn (Just handle) Nothing) + ("illegal buffer size " ++ showsPrec 9 (sz::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 @@ -1,47 +1,54 @@ -{-# OPTIONS_GHC -#include "HsBase.h" #-} +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , RoleAnnotations + #-} + +{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.IO.Internal --- Copyright : (c) The University of Glasgow 2001 +-- Copyright : (c) The University of Glasgow 2001-2012 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Array.Base) -- -- Mutable boxed and unboxed arrays in the IO monad. -- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- ----------------------------------------------------------------------------- --- #hide module Data.Array.IO.Internals ( - IOArray(..), -- instance of: Eq, Typeable - IOUArray(..), -- instance of: Eq, Typeable - castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) -#ifdef __GLASGOW_HASKELL__ - unsafeThawIOUArray, -#endif - ) where + IOArray(..), -- instance of: Eq, Typeable + IOUArray(..), -- instance of: Eq, Typeable + castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) + unsafeThawIOUArray, + unsafeFreezeIOUArray + ) where import Data.Int import Data.Word -import Data.Typeable -#ifdef __HUGS__ -import Hugs.IOArray -#endif +import Control.Monad.ST ( RealWorld, stToIO ) +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) -import Control.Monad.ST ( RealWorld, stToIO ) -import Foreign.Ptr ( Ptr, FunPtr ) -import Foreign.StablePtr ( StablePtr ) import Data.Array.Base -import Data.Ix -#ifdef __GLASGOW_HASKELL__ -import GHC.IOBase (IOArray(..)) -#endif /* __GLASGOW_HASKELL__ */ - -#include "Typeable.h" +import GHC.IOArray (IOArray(..)) ----------------------------------------------------------------------------- -- Flat unboxed mutable arrays (IO monad) @@ -55,8 +62,8 @@ -- are supported: see "Data.Array.MArray" for a list of instances. -- newtype IOUArray i e = IOUArray (STUArray RealWorld i e) - -INSTANCE_TYPEABLE2(IOUArray,iOUArrayTc,"IOUArray") +-- Both parameters have class-based invariants. See also #9220. +type role IOUArray nominal nominal instance Eq (IOUArray i e) where IOUArray s1 == IOUArray s2 = s1 == s2 @@ -375,9 +382,8 @@ marr' <- castSTUArray marr return (IOUArray marr') -#ifdef __GLASGOW_HASKELL__ {-# INLINE unsafeThawIOUArray #-} -unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) unsafeThawIOUArray arr = stToIO $ do marr <- unsafeThawSTUArray arr return (IOUArray marr) @@ -386,7 +392,7 @@ "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray #-} -thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +thawIOUArray :: UArray ix e -> IO (IOUArray ix e) thawIOUArray arr = stToIO $ do marr <- thawSTUArray arr return (IOUArray marr) @@ -396,17 +402,16 @@ #-} {-# INLINE unsafeFreezeIOUArray #-} -unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) {-# RULES "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray #-} -freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) {-# RULES "freeze/IOUArray" freeze = freezeIOUArray #-} -#endif /* __GLASGOW_HASKELL__ */ diff --git a/Data/Array/IO/Safe.hs b/Data/Array/IO/Safe.hs new file mode 100644 --- /dev/null +++ b/Data/Array/IO/Safe.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.IO.Safe +-- 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.MArray) +-- +-- Mutable boxed and unboxed arrays in the IO monad. +-- . +-- Safe API only of "Data.Array.IO". +-- +-- @since 0.4.0.0 +----------------------------------------------------------------------------- + +module Data.Array.IO.Safe ( + -- * @IO@ arrays with boxed elements + IOArray, -- instance of: Eq, Typeable + + -- * @IO@ arrays with unboxed elements + IOUArray, -- instance of: Eq, Typeable + + -- * Overloaded mutable array interface + module Data.Array.MArray.Safe, + + -- * Doing I\/O with @IOUArray@s + hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int + hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO () + ) where + +import Data.Array.IO +import Data.Array.MArray.Safe diff --git a/Data/Array/MArray.hs b/Data/Array/MArray.hs --- a/Data/Array/MArray.hs +++ b/Data/Array/MArray.hs @@ -1,20 +1,22 @@ +{-# LANGUAGE CPP, Trustworthy #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Array.MArray -- 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.Base) -- -- An overloaded interface to mutable arrays. For array types which can be --- used with this interface, see "Data.Array.IO", "Data.Array.ST", +-- used with this interface, see "Data.Array.IO", "Data.Array.ST", -- and "Data.Array.Storable". -- ----------------------------------------------------------------------------- -module Data.Array.MArray ( +module Data.Array.MArray ( -- * Class of mutable array types MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class @@ -25,11 +27,22 @@ newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e) newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e) newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) + newGenArray, -- :: (MArray a e m, Ix i) => (i,i) -> (i -> m e) -> m (a i e) -- * Reading and writing mutable arrays readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m () + modifyArray, + modifyArray', + -- * Array folds + foldlMArray', + foldrMArray', + mapMArrayM_, + forMArrayM_, + foldlMArrayM', + foldrMArrayM', + -- * Derived arrays mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) @@ -41,13 +54,11 @@ -- * Conversions between mutable and immutable arrays freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) - unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) - unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) ) where import Data.Ix +import Data.Array.Base #ifdef __HADDOCK__ import Data.Array.IArray #endif -import Data.Array.Base diff --git a/Data/Array/MArray/Safe.hs b/Data/Array/MArray/Safe.hs new file mode 100644 --- /dev/null +++ b/Data/Array/MArray/Safe.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP, Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.MArray.Safe +-- 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.Base) +-- +-- An overloaded interface to mutable arrays. For array types which can be +-- used with this interface, see "Data.Array.IO", "Data.Array.ST", +-- and "Data.Array.Storable". +-- . +-- Safe API only of "Data.Array.MArray". +-- +-- @since 0.4.0.0 +----------------------------------------------------------------------------- + +module Data.Array.MArray.Safe ( + -- * Class of mutable array types + MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class + + -- * The @Ix@ class and operations + module Data.Ix, + + -- * Constructing mutable arrays + newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e) + newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e) + newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) + newGenArray, -- :: (MArray a e m, Ix i) => (i,i) -> (i -> m e) -> m (a i e) + + -- * Reading and writing mutable arrays + readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e + writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m () + + -- * Array folds + foldlMArray', + foldrMArray', + mapMArrayM_, + forMArrayM_, + foldlMArrayM', + foldrMArrayM', + + -- * Derived arrays + mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) + mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) + + -- * Deconstructing mutable arrays + getBounds, -- :: (MArray a e m, Ix i) => a i e -> m (i,i) + getElems, -- :: (MArray a e m, Ix i) => a i e -> m [e] + getAssocs, -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)] + + -- * Conversions between mutable and immutable arrays + freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) + thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) + ) where + +import Data.Ix +import Data.Array.Base +#ifdef __HADDOCK__ +import Data.Array.IArray +#endif + diff --git a/Data/Array/ST.hs b/Data/Array/ST.hs --- a/Data/Array/ST.hs +++ b/Data/Array/ST.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE RankNTypes, Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.ST -- 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.MArray) @@ -13,41 +14,30 @@ ----------------------------------------------------------------------------- module Data.Array.ST ( - -- * Boxed arrays - STArray, -- instance of: Eq, MArray + STArray, -- instance of: Eq, MArray runSTArray, -- * Unboxed arrays - STUArray, -- instance of: Eq, MArray + STUArray, -- instance of: Eq, MArray runSTUArray, - castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b) -- * Overloaded mutable array interface module Data.Array.MArray, ) where +import Data.Array.Base ( STUArray, UArray, unsafeFreezeSTUArray ) import Data.Array.MArray -import Data.Array.Base ( STUArray, castSTUArray, UArray, unsafeFreezeSTUArray ) -import Control.Monad.ST ( ST, runST ) - -#ifdef __HUGS__ -import Hugs.Array ( Array ) -import Hugs.ST ( STArray, unsafeFreezeSTArray ) -#endif +import Control.Monad.ST ( ST, runST ) -#ifdef __GLASGOW_HASKELL__ -import GHC.Arr ( STArray, Array, unsafeFreezeSTArray ) -#endif +import GHC.Arr ( STArray, Array, unsafeFreezeSTArray ) -- | A safe way to create and work with a mutable array before returning an -- immutable array for later perusal. This function avoids copying -- the array before returning it - it uses 'unsafeFreeze' internally, but -- this wrapper is a safe interface to that function. -- -runSTArray :: (Ix i) - => (forall s . ST s (STArray s i e)) - -> Array i e +runSTArray :: (forall s . ST s (STArray s i e)) -> Array i e runSTArray st = runST (st >>= unsafeFreezeSTArray) -- | A safe way to create and work with an unboxed mutable array before @@ -56,18 +46,16 @@ -- 'unsafeFreeze' internally, but this wrapper is a safe interface to -- that function. -- -runSTUArray :: (Ix i) - => (forall s . ST s (STUArray s i e)) - -> UArray i e +runSTUArray :: (forall s . ST s (STUArray s i e)) -> UArray i e runSTUArray st = runST (st >>= unsafeFreezeSTUArray) -- INTERESTING... this is the type we'd like to give to runSTUArray: -- --- runSTUArray :: (Ix i, IArray UArray e, --- forall s. MArray (STUArray s) e (ST s)) --- => (forall s . ST s (STUArray s i e)) --- -> UArray i e +-- runSTUArray :: (Ix i, IArray UArray e, +-- forall s. MArray (STUArray s) e (ST s)) +-- => (forall s . ST s (STUArray s i e)) +-- -> UArray i e -- -- Note the quantified constraint. We dodged the problem by using -- unsafeFreezeSTUArray directly in the defn of runSTUArray above, but diff --git a/Data/Array/ST/Safe.hs b/Data/Array/ST/Safe.hs new file mode 100644 --- /dev/null +++ b/Data/Array/ST/Safe.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.ST.Safe +-- Copyright : (c) The University of Glasgow 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.MArray) +-- +-- Mutable boxed and unboxed arrays in the 'Control.Monad.ST.ST' monad. +-- +-- Safe API only of "Data.Array.ST". +-- +-- @since 0.4.0.0 +----------------------------------------------------------------------------- + +module Data.Array.ST.Safe ( + -- * Boxed arrays + STArray, -- instance of: Eq, MArray + runSTArray, + + -- * Unboxed arrays + STUArray, -- instance of: Eq, MArray + runSTUArray, + + -- * Overloaded mutable array interface + module Data.Array.MArray.Safe, + ) where + +import Data.Array.ST +import Data.Array.MArray.Safe + diff --git a/Data/Array/Storable.hs b/Data/Array/Storable.hs --- a/Data/Array/Storable.hs +++ b/Data/Array/Storable.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Storable -- 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.MArray) @@ -20,76 +21,21 @@ ----------------------------------------------------------------------------- module Data.Array.Storable ( - -- * Arrays of 'Storable' things. StorableArray, -- data StorableArray index element - -- -- index type must be in class Ix - -- -- element type must be in class Storable - + -- + index type must be in class Ix + -- + element type must be in class Storable + -- * Overloaded mutable array interface -- | Module "Data.Array.MArray" provides the interface of storable arrays. -- They are instances of class 'MArray' (with the 'IO' monad). module Data.Array.MArray, - + -- * Accessing the pointer to the array contents - withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a - - touchStorableArray, -- :: StorableArray i e -> IO () + withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a - unsafeForeignPtrToStorableArray - ) - where + touchStorableArray, -- :: StorableArray i e -> IO () + ) where -import Data.Array.Base import Data.Array.MArray -import Foreign hiding (newArray) - --- |The array type -data StorableArray i e = StorableArray !i !i Int !(ForeignPtr e) - -instance Storable e => MArray StorableArray e IO where - getBounds (StorableArray l u _ _) = return (l,u) - - getNumElements (StorableArray _l _u n _) = return n - - newArray (l,u) initialValue = do - fp <- mallocForeignPtrArray size - withForeignPtr fp $ \a -> - sequence_ [pokeElemOff a i initialValue | i <- [0..size-1]] - return (StorableArray l u size fp) - where - size = rangeSize (l,u) - - unsafeNewArray_ (l,u) = do - let n = rangeSize (l,u) - fp <- mallocForeignPtrArray n - return (StorableArray l u n fp) - - newArray_ = unsafeNewArray_ - - unsafeRead (StorableArray _ _ _ fp) i = - withForeignPtr fp $ \a -> peekElemOff a i - - unsafeWrite (StorableArray _ _ _ fp) i e = - withForeignPtr fp $ \a -> pokeElemOff a i e - --- |The pointer to the array contents is obtained by 'withStorableArray'. --- The idea is similar to 'ForeignPtr' (used internally here). --- The pointer should be used only during execution of the 'IO' action --- retured by the function passed as argument to 'withStorableArray'. -withStorableArray :: StorableArray i e -> (Ptr e -> IO a) -> IO a -withStorableArray (StorableArray _ _ _ fp) f = withForeignPtr fp f - --- |If you want to use it afterwards, ensure that you --- 'touchStorableArray' after the last use of the pointer, --- so the array is not freed too early. -touchStorableArray :: StorableArray i e -> IO () -touchStorableArray (StorableArray _ _ _ fp) = touchForeignPtr fp - --- |Construct a 'StorableArray' from an arbitrary 'ForeignPtr'. It is --- the caller's responsibility to ensure that the 'ForeignPtr' points to --- an area of memory sufficient for the specified bounds. -unsafeForeignPtrToStorableArray - :: Ix i => ForeignPtr e -> (i,i) -> IO (StorableArray i e) -unsafeForeignPtrToStorableArray p (l,u) = - return (StorableArray l u (rangeSize (l,u)) p) +import Data.Array.Storable.Internals diff --git a/Data/Array/Storable/Internals.hs b/Data/Array/Storable/Internals.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Storable/Internals.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RoleAnnotations #-} +{-# OPTIONS_HADDOCK not-home #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Storable.Internals +-- Copyright : (c) The University of Glasgow 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.MArray) +-- +-- Actual implementation of "Data.Array.Storable". +-- +-- @since 0.4.0.0 +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +----------------------------------------------------------------------------- + +module Data.Array.Storable.Internals ( + StorableArray(..), + withStorableArray, + touchStorableArray, + unsafeForeignPtrToStorableArray, + ) where + +import Data.Array.Base +import Data.Array.MArray +import Foreign hiding (newArray) + +-- |The array type +data StorableArray i e = StorableArray !i !i Int !(ForeignPtr e) +-- Both parameters have class-based invariants. See also #9220. +type role StorableArray nominal nominal + +instance Storable e => MArray StorableArray e IO where + getBounds (StorableArray l u _ _) = return (l,u) + + getNumElements (StorableArray _l _u n _) = return n + + newArray (l,u) initialValue = do + fp <- mallocForeignPtrArray size + withForeignPtr fp $ \a -> + sequence_ [pokeElemOff a i initialValue | i <- [0..size-1]] + return (StorableArray l u size fp) + where + size = rangeSize (l,u) + + unsafeNewArray_ (l,u) = do + let n = rangeSize (l,u) + fp <- mallocForeignPtrArray n + return (StorableArray l u n fp) + + newArray_ = unsafeNewArray_ + + unsafeRead (StorableArray _ _ _ fp) i = + withForeignPtr fp $ \a -> peekElemOff a i + + unsafeWrite (StorableArray _ _ _ fp) i e = + withForeignPtr fp $ \a -> pokeElemOff a i e + +-- |The pointer to the array contents is obtained by 'withStorableArray'. +-- The idea is similar to 'ForeignPtr' (used internally here). +-- The pointer should be used only during execution of the 'IO' action +-- retured by the function passed as argument to 'withStorableArray'. +withStorableArray :: StorableArray i e -> (Ptr e -> IO a) -> IO a +withStorableArray (StorableArray _ _ _ fp) f = withForeignPtr fp f + +-- |If you want to use it afterwards, ensure that you +-- 'touchStorableArray' after the last use of the pointer, +-- so the array is not freed too early. +touchStorableArray :: StorableArray i e -> IO () +touchStorableArray (StorableArray _ _ _ fp) = touchForeignPtr fp + +-- |Construct a 'StorableArray' from an arbitrary 'ForeignPtr'. It is +-- the caller's responsibility to ensure that the 'ForeignPtr' points to +-- an area of memory sufficient for the specified bounds. +unsafeForeignPtrToStorableArray + :: Ix i => ForeignPtr e -> (i,i) -> IO (StorableArray i e) +unsafeForeignPtrToStorableArray p (l,u) = + return (StorableArray l u (rangeSize (l,u)) p) + diff --git a/Data/Array/Storable/Safe.hs b/Data/Array/Storable/Safe.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Storable/Safe.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Storable.Safe +-- 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.MArray) +-- +-- A storable array is an IO-mutable array which stores its +-- contents in a contiguous memory block living in the C +-- heap. Elements are stored according to the class 'Storable'. +-- You can obtain the pointer to the array contents to manipulate +-- elements from languages like C. +-- +-- It is similar to 'Data.Array.IO.IOUArray' but slower. +-- Its advantage is that it's compatible with C. +-- +-- Safe API only of "Data.Array.Storable". +-- +-- @since 0.4.0.0 +----------------------------------------------------------------------------- + +module Data.Array.Storable.Safe ( + -- * Arrays of 'Storable' things. + StorableArray, -- data StorableArray index element + -- + index type must be in class Ix + -- + element type must be in class Storable + + -- * Overloaded mutable array interface + -- | Module "Data.Array.MArray" provides the interface of storable arrays. + -- They are instances of class 'MArray' (with the 'IO' monad). + module Data.Array.MArray.Safe, + + -- * Accessing the pointer to the array contents + withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a + + touchStorableArray, -- :: StorableArray i e -> IO () + ) where + +import Data.Array.MArray.Safe +import Data.Array.Storable.Internals + diff --git a/Data/Array/Unboxed.hs b/Data/Array/Unboxed.hs --- a/Data/Array/Unboxed.hs +++ b/Data/Array/Unboxed.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Unboxed -- 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) @@ -13,12 +14,13 @@ ----------------------------------------------------------------------------- module Data.Array.Unboxed ( - -- * Arrays with unboxed elements - UArray, + -- * Arrays with unboxed elements + UArray, - -- * The overloaded immutable array interface - module Data.Array.IArray, - ) where + -- * The overloaded immutable array interface + module Data.Array.IArray, + ) where -import Data.Array.IArray import Data.Array.Base +import Data.Array.IArray + diff --git a/Data/Array/Unsafe.hs b/Data/Array/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Unsafe.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Unsafe +-- Copyright : (c) The University of Glasgow 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.MArray) +-- +-- Contains the various unsafe operations that can be performed +-- on arrays. +-- +-- @since 0.4.0.0 +----------------------------------------------------------------------------- + +module Data.Array.Unsafe ( + -- * Unsafe operations + castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b) + castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b) + + unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) + unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) + + unsafeForeignPtrToStorableArray -- :: Ix i => ForeignPtr e -> (i,i) + -- -> IO (StorableArray i e) + ) where + + +import Data.Array.Base ( castSTUArray, unsafeFreeze, unsafeThaw ) +import Data.Array.IO.Internals ( castIOUArray ) +import Data.Array.Storable.Internals ( unsafeForeignPtrToStorableArray ) + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -81,3 +81,4 @@ be a definition of the Haskell 98 Foreign Function Interface. ----------------------------------------------------------------------------- + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -4,3 +4,4 @@ main :: IO () main = defaultMain + diff --git a/array.cabal b/array.cabal --- a/array.cabal +++ b/array.cabal @@ -1,46 +1,56 @@ -name: array -version: 0.2.0.0 -license: BSD3 -license-file: LICENSE +cabal-version: >= 1.10 +name: array +version: 0.5.8.0 + +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE maintainer: libraries@haskell.org -synopsis: Mutable and immutable arrays -category: Data Structures +bug-reports: https://gitlab.haskell.org/ghc/packages/array/issues +synopsis: Mutable and immutable arrays +category: Data Structures +build-type: Simple 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 -build-type: Simple -extra-source-files: include/Typeable.h + In addition to providing the "Data.Array" module + , + this package also defines the classes 'IArray' of + immutable arrays and 'MArray' of arrays mutable within appropriate + monads, as well as some instances of these classes. +extra-source-files: changelog.md + +source-repository head + type: git + location: http://gitlab.haskell.org/ghc/packages/array.git + library - build-depends: base - if !impl(nhc98) - build-depends: syb + default-language: Haskell2010 + other-extensions: + BangPatterns, + CPP, + FlexibleContexts, + FlexibleInstances, + MagicHash, + MultiParamTypeClasses, + RankNTypes, + Trustworthy, + UnboxedTuples, + UnliftedFFITypes + build-depends: base >= 4.9 && < 4.21 + ghc-options: -Wall 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.Safe Data.Array.IO.Internals Data.Array.MArray + Data.Array.MArray.Safe Data.Array.ST + Data.Array.ST.Safe Data.Array.Storable + Data.Array.Storable.Safe + Data.Array.Storable.Internals Data.Array.Unboxed - extensions: - MultiParamTypeClasses, - FlexibleContexts, - FlexibleInstances, - TypeSynonymInstances - if impl(ghc) - extensions: - Rank2Types, - MagicHash, - UnboxedTuples, - ForeignFunctionInterface, - UnliftedFFITypes - include-dirs: include + Data.Array.Unsafe diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,101 @@ +# Changelog for [`array` package](http://hackage.haskell.org/package/array) + +## 0.5.8.0 *Aug 2024* + +### Added + + * Folds for arrays: `foldrArray`, `foldlArray'`, `foldlArray`, `foldrArray'`, + `traverseArray_`, `forArray_`, `foldlArrayM'`, `foldrArrayM'`. + * Folds for mutable arrays: `foldlMArray'`, `foldrMArray'`, `mapMArrayM_`, + `forMArrayM_`, `foldlMArrayM'`, `foldrMArrayM'`. + +### Fixed + + * Fix a build error that the package can't be buildable before `base-4.14`. + +## 0.5.7.0 *April 2024* + +### Changed + + * `MArray` now has a `MINIMAL` pragma + * Optimisation of `newListArray` and `newGenArray` + +## 0.5.6.0 *July 2023* + +### Changed + + * `listArray` and `newListArray` are now good consumers of the input list + * Bump base bound to `<4.20` + +### Added + + * Add the `genArray` and `newGenArray` function + * Add `Data.Array.MArray.modifyArray` and `Data.Array.MArray.modifyArray'` + These are also exposed from `Data.Array.IO`, `Data.Array.ST`, and + `Data.Array.Storable`. + * Add `Data.Array.IArray.(!?)` + +### Fixed + + * Array docs regarding constructing arrays + * Update note [Inlining and fusion] + * Unboxed Bool arrays no longer cause spurious alarms + when used with `-fcheck-prim-bounds` + * Replace Haddock hide pragma with not-home to make the Haddocks more readable + +## 0.5.5.0 *February 2022* + + * Compatibility with GHC's new JavaScript backend. + +## 0.5.4.0 *July 2019* + + * Add a `Read` instance for `UArray` + +## 0.5.3.0 *Oct 2018* + + * Bundled with GHC 8.6.2 + * Drop support for GHC versions prior to GHC 8.0 + +## 0.5.2.0 *Jul 2017* + + * Bundled with GHC 8.2.1 + * Overflow check in `unsafeNewArray` (#229) + * Fix and simplify handling of `Bool` arrays + * Export `unsafeFreezeIOUArray` from `Data.Array.IO.Internals` + * Drop support for GHC versions prior to GHC 7.8 + +## 0.5.1.1 *Apr 2016* + + * Bundled with GHC 8.0.1 + * Use `@since` syntax in Haddock comments + * Don't needlessly call `bounds` in `Data.Array.Base.elems` (#10014) + +## 0.5.1.0 *Mar 2015* + + * Bundled with GHC 7.10.1 + * Add role annotations for GHC >= 7.8 (#9220) + +## 0.5.0.0 *Nov 2013* + + * Update to Cabal 1.10 format + * Remove NHC and Hugs specific code + * Remove deprecated function exports `Data.Array.IO.castIOUArray`, + `Data.Array.MArray.unsafeFreeze`, `Data.Array.MArray.unsafeThaw`, + and `Data.Array.ST.castSTUArray`; These functions are still + available from the `Data.Array.Unsafe` module. + +## 0.4.0.1 *Sep 2012* + + * Bundled with GHC 7.6.1 + * Fix inline rule shadowing warnings + +## 0.4.0.0 *Feb 2012* + + * Bundled with GHC 7.4.1 + * Add support for SafeHaskell + * New `Data.Array.IO.Safe` module + * New `Data.Array.MArray.safe` module + * New `Data.Array.ST.safe` module + * New `Data.Array.Storable.Internals` module + * New `Data.Array.Storable.Safe` module + * New `Data.Array.Unsafe` module diff --git a/include/Typeable.h b/include/Typeable.h deleted file mode 100644 --- a/include/Typeable.h +++ /dev/null @@ -1,69 +0,0 @@ -{- -------------------------------------------------------------------------- -// Macros to help make Typeable instances. -// -// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines -// -// instance Typeable/n/ tc -// instance Typeable a => Typeable/n-1/ (tc a) -// instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) -// ... -// instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) -// -------------------------------------------------------------------------- --} - -#ifndef TYPEABLE_H -#define TYPEABLE_H - -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } - -#ifdef __GLASGOW_HASKELL__ - --- // For GHC, the extra instances follow from general instance declarations --- // defined in Data.Typeable. - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } - -#else /* !__GLASGOW_HASKELL__ */ - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable1 (tycon a) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ - typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable2 (tycon a) where { \ - typeOf2 = typeOf2Default }; \ -instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ - typeOf = typeOfDefault } - -#endif /* !__GLASGOW_HASKELL__ */ - -#endif