X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelArr.lhs;h=e930bad39832614469057b945f7862bc56373b4c;hb=bb864806cef069b0bba9fbaa92b4135f99041dcd;hp=a03434615b4de97ada2eee8e93711d0320df404c;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index a034346..e930bad 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -6,44 +6,263 @@ Array implementation, @PrelArr@ exports the basic array types and operations. +For byte-arrays see @PrelByteArr@. + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} module PrelArr where import {-# SOURCE #-} PrelErr ( error ) -import Ix import PrelList (foldl) +import PrelEnum +import PrelNum import PrelST import PrelBase -import PrelCCall import PrelAddr import PrelGHC +import PrelShow infixl 9 !, // + +default () \end{code} + +%********************************************************* +%* * +\subsection{The @Ix@ class} +%* * +%********************************************************* + \begin{code} -{-# SPECIALISE array :: (Int,Int) -> [(Int,b)] -> Array Int b #-} -array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b +class (Ord a) => Ix a where + range :: (a,a) -> [a] + index, unsafeIndex :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + + -- Must specify one of index, unsafeIndex + index b i | inRange b i = unsafeIndex b i + | otherwise = error "Error in array index" + unsafeIndex b i = index b i +\end{code} -{-# SPECIALISE (!) :: Array Int b -> Int -> b #-} -(!) :: (Ix a) => Array a b -> a -> b -{-# SPECIALISE bounds :: Array Int b -> (Int,Int) #-} -bounds :: (Ix a) => Array a b -> (a,a) +%********************************************************* +%* * +\subsection{Instances of @Ix@} +%* * +%********************************************************* -{-# SPECIALISE (//) :: Array Int b -> [(Int,b)] -> Array Int b #-} -(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b +\begin{code} +-- abstract these errors from the relevant index functions so that +-- the guts of the function will be small enough to inline. -{-# SPECIALISE accum :: (b -> c -> b) -> Array Int b -> [(Int,c)] -> Array Int b #-} -accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +{-# NOINLINE indexError #-} +indexError :: Show a => (a,a) -> a -> String -> b +indexError rng i tp + = error (showString "Ix{" . showString tp . showString "}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 rng) "") -{-# SPECIALISE accumArray :: (b -> c -> b) -> b -> (Int,Int) -> [(Int,c)] -> Array Int b #-} -accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +---------------------------------------------------------------------- +instance Ix Char where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromEnum i - fromEnum m + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Char" + + inRange (m,n) i = m <= i && i <= n + +---------------------------------------------------------------------- +instance Ix Int where + {-# INLINE range #-} + -- The INLINE stops the build in the RHS from getting inlined, + -- so that callers can fuse with the result of range + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = i - m + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Int" + + {-# INLINE inRange #-} + inRange (I# m,I# n) (I# i) = m <=# i && i <=# n + +---------------------------------------------------------------------- +instance Ix Integer where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromInteger (i - m) + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Integer" + + inRange (m,n) i = m <= i && i <= n + + +---------------------------------------------------------------------- +instance Ix Bool where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Bool" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix Ordering where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Ordering" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix () where + {-# INLINE range #-} + range ((), ()) = [()] + {-# INLINE unsafeIndex #-} + unsafeIndex ((), ()) () = 0 + {-# INLINE inRange #-} + inRange ((), ()) () = True + {-# INLINE index #-} + index b i = unsafeIndex b i + + +---------------------------------------------------------------------- +instance (Ix a, Ix b) => Ix (a, b) where -- as derived + {-# SPECIALISE instance Ix (Int,Int) #-} + + {- INLINE range #-} + range ((l1,l2),(u1,u2)) = + [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + + {- INLINE unsafeIndex #-} + unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = + unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 + + {- INLINE inRange #-} + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + {-# SPECIALISE instance Ix (Int,Int,Int) #-} + + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3)] + + unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)) + + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where + range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + [(i1,i2,i3,i4) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4)] + + unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1))) + + inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 + + -- Default method for index + +instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where + range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = + [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4), + i5 <- range (l5,u5)] + + unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)))) + + inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 && + inRange (l5,u5) i5 + + -- Default method for index \end{code} +%******************************************************** +%* * +\subsection{Size of @Ix@ interval} +%* * +%******************************************************** + +The @rangeSize@ operator returns the number of elements +in the range for an @Ix@ pair. + +\begin{code} +{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-} +{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-} +unsafeRangeSize :: (Ix a) => (a,a) -> Int +unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + +{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-} +{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-} +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 + | otherwise = 0 + +-- Note that the following is NOT right +-- rangeSize (l,h) | l <= h = index b h + 1 +-- | otherwise = 0 +-- +-- Because it might be the case that l (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a \begin{code} type IPr = (Int, Int) -data Ix ix => Array ix elt = Array (ix,ix) (Array# elt) -data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray# -data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) -data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) - -instance CCallable (MutableByteArray s ix) -instance CCallable (MutableByteArray# s) +data Ix ix => Array ix elt = Array ix ix (Array# elt) +data Ix ix => STArray s ix elt = STArray ix ix (MutableArray# s elt) -instance CCallable (ByteArray ix) -instance CCallable ByteArray# -data MutableVar s a = MutableVar (MutVar# s a) +data STRef s a = STRef (MutVar# s a) -instance Eq (MutableVar s a) where - MutableVar v1# == MutableVar v2# +instance Eq (STRef s a) where + STRef v1# == STRef v2# = sameMutVar# v1# v2# -- just pointer equality on arrays: -instance Eq (MutableArray s ix elt) where - MutableArray _ arr1# == MutableArray _ arr2# +instance Eq (STArray s ix elt) where + STArray _ _ arr1# == STArray _ _ arr2# = sameMutableArray# arr1# arr2# - -instance Eq (MutableByteArray s ix) where - MutableByteArray _ arr1# == MutableByteArray _ arr2# - = sameMutableByteArray# arr1# arr2# \end{code} %********************************************************* @@ -87,17 +295,17 @@ instance Eq (MutableByteArray s ix) where %********************************************************* \begin{code} -newVar :: a -> ST s (MutableVar s a) -readVar :: MutableVar s a -> ST s a -writeVar :: MutableVar s a -> a -> ST s () +newSTRef :: a -> ST s (STRef s a) +readSTRef :: STRef s a -> ST s a +writeSTRef :: STRef s a -> a -> ST s () -newVar init = ST $ \ s# -> +newSTRef init = ST $ \ s# -> case (newMutVar# init s#) of { (# s2#, var# #) -> - (# s2#, MutableVar var# #) } + (# s2#, STRef var# #) } -readVar (MutableVar var#) = ST $ \ s# -> readMutVar# var# s# +readSTRef (STRef var#) = ST $ \ s# -> readMutVar# var# s# -writeVar (MutableVar var#) val = ST $ \ s# -> +writeSTRef (STRef var#) val = ST $ \ s# -> case writeMutVar# var# val s# of { s2# -> (# s2#, () #) } \end{code} @@ -111,95 +319,160 @@ writeVar (MutableVar var#) val = ST $ \ s# -> "array", "!" and "bounds" are basic; the rest can be defined in terms of them \begin{code} -bounds (Array b _) = b +bounds :: (Ix a) => Array a b -> (a,a) +{-# INLINE bounds #-} +bounds (Array l u _) = (l,u) -(Array bounds arr#) ! i - = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range +assocs :: (Ix a) => Array a b -> [(a,b)] +{-# INLINE assocs #-} -- Want to fuse the list comprehension +assocs a = [(i, a!i) | i <- indices a] + +indices :: (Ix a) => Array a b -> [a] +{-# INLINE indices #-} +indices = range . bounds + +{-# SPECIALISE amap :: (b -> c) -> Array Int b -> Array Int c #-} +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +amap f a = array b [(i, f (a!i)) | i <- range b] + where b = bounds a + +{-# SPECIALISE (!) :: Array Int b -> Int -> b #-} +(!) :: (Ix a) => Array a b -> a -> b +(Array l u arr#) ! i + = let n# = case (index (l,u) i) of { I# x -> x } -- index fails if out of range in case (indexArray# arr# n#) of - (# _, v #) -> v + (# v #) -> v -#ifdef USE_FOLDR_BUILD -{-# INLINE array #-} -#endif -array ixs@(ix_start, ix_end) ivs = - runST ( ST $ \ s -> - case (newArray ixs arrEleBottom) of { ST new_array_thing -> - case (new_array_thing s) of { (# s#, arr@(MutableArray _ arr#) #) -> - let - fill_in s# [] = s# - fill_in s# ((i,v):ivs) = - case (index ixs i) of { I# n# -> - case writeArray# arr# n# v s# of { s2# -> - fill_in s2# ivs }} - in - - case (fill_in s# ivs) of { s# -> - case (freezeArray arr) of { ST freeze_array_thing -> - freeze_array_thing s# }}}}) +array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b +{-# INLINE array #-} +array ixs ivs + = case rangeSize ixs of { I# n -> + runST ( ST $ \ s1 -> + case newArray# n arrEleBottom s1 of { (# s2, marr #) -> + foldr (fill ixs marr) (done ixs marr) ivs s2 + })} + +fill :: Ix ix => (ix,ix) -> MutableArray# s elt + -> (ix,elt) -> STRep s a -> STRep s a +{-# INLINE fill #-} +fill ixs marr (i,v) next = \s1 -> case index ixs i of { I# n -> + case writeArray# marr n v s1 of { s2 -> + next s2 }} + +done :: Ix ix => (ix,ix) -> MutableArray# s elt + -> STRep s (Array ix elt) +{-# INLINE done #-} +done (l,u) marr = \s1 -> + case unsafeFreezeArray# marr s1 of { (# s2, arr #) -> + (# s2, Array l u arr #) } + +arrEleBottom :: a arrEleBottom = error "(Array.!): undefined array element" -fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s () -fill_it_in arr lst - = foldr fill_one_in (return ()) lst - where -- **** STRICT **** (but that's OK...) - fill_one_in (i, v) rst - = writeArray arr i v >> rst ----------------------------------------------------------------------- --- these also go better with magic: (//), accum, accumArray +-- These also go better with magic: (//), accum, accumArray +-- *** NB *** We INLINE them all so that their foldr's get to the call site +(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b +{-# INLINE (//) #-} old_array // ivs = runST (do -- copy the old array: - arr <- thawArray old_array + arr <- thawSTArray old_array -- now write the new elements into the new array: fill_it_in arr ivs - freezeArray arr + freezeSTArray arr ) - where - bottom = error "(Array.//): error in copying old array\n" -zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s () +fill_it_in :: Ix ix => STArray s ix elt -> [(ix, elt)] -> ST s () +{-# INLINE fill_it_in #-} +fill_it_in arr lst = foldr (fill_one_in arr) (return ()) lst + -- **** STRICT **** (but that's OK...) + +fill_one_in arr (i, v) rst = writeSTArray arr i v >> rst + +zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> STArray s ix elt -> [(ix,elt2)] -> ST s () -- zap_with_f: reads an elem out first, then uses "f" on that and the new value +{-# INLINE zap_with_f #-} zap_with_f f arr lst - = foldr zap_one (return ()) lst - where - zap_one (i, new_v) rst = do - old_v <- readArray arr i - writeArray arr i (f old_v new_v) + = foldr (zap_one f arr) (return ()) lst + +zap_one f arr (i, new_v) rst = do + old_v <- readSTArray arr i + writeSTArray arr i (f old_v new_v) rst +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +{-# INLINE accum #-} accum f old_array ivs = runST (do -- copy the old array: - arr <- thawArray old_array + arr <- thawSTArray old_array -- now zap the elements in question with "f": zap_with_f f arr ivs - freezeArray arr + freezeSTArray arr ) - where - bottom = error "Array.accum: error in copying old array\n" + +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +{-# INLINE accumArray #-} accumArray f zero ixs ivs = runST (do - arr# <- newArray ixs zero - zap_with_f f arr# ivs - freezeArray arr# + arr <- newSTArray ixs zero + zap_with_f f arr ivs + freezeSTArray arr ) \end{code} %********************************************************* %* * +\subsection{Array instances} +%* * +%********************************************************* + + +\begin{code} +instance Ix a => Functor (Array a) where + fmap = amap + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + a /= a' = assocs a /= assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + compare a b = compare (assocs a) (assocs b) + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + showList = showList__ (showsPrec 0) + +{- +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) + readList = readList__ (readsPrec 0) +-} +\end{code} + + +%********************************************************* +%* * \subsection{Operations on mutable arrays} %* * %********************************************************* Idle ADR question: What's the tradeoff here between flattening these -datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using +datatypes into @STArray ix ix (MutableArray# s elt)@ and using it as is? As I see it, the former uses slightly less heap and provides faster access to the individual parts of the bounds while the code used has the benefit of providing a ready-made @(lo, hi)@ pair as @@ -212,211 +485,40 @@ it frequently. Now we've got the overloading specialiser things might be different, though. \begin{code} -newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) -newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray - :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) +newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt) -{-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), - (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt) +{-# SPECIALIZE newSTArray :: IPr -> elt -> ST s (STArray s Int elt), + (IPr,IPr) -> elt -> ST s (STArray s IPr elt) #-} -{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-} - -newArray ixs init = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newArray# n# init s#) of { (# s2#, arr# #) -> - (# s2#, MutableArray ixs arr# #) }} - -newCharArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newCharArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -newIntArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newIntArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -newWordArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newWordArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -newAddrArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newAddrArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -newFloatArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newFloatArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -newDoubleArray ixs = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case (newDoubleArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray ixs barr# #) }} - -boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) -boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) - -{-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-} -{-# SPECIALIZE boundsOfByteArray :: MutableByteArray s Int -> IPr #-} - -boundsOfArray (MutableArray ixs _) = ixs -boundsOfByteArray (MutableByteArray ixs _) = ixs - -readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt - -readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char -readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int -readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word -readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr -readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float -readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double - -{-# SPECIALIZE readArray :: MutableArray s Int elt -> Int -> ST s elt, - MutableArray s IPr elt -> IPr -> ST s elt - #-} -{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-} -{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-} -{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-} ---NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-} -{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-} - -readArray (MutableArray ixs arr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readArray# arr# n# s# of { (# s2#, r #) -> - (# s2#, r #) }} +newSTArray (l,u) init = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newArray# n# init s#) of { (# s2#, arr# #) -> + (# s2#, STArray l u arr# #) }} -readCharArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readCharArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, C# r# #) }} - -readIntArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readIntArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, I# r# #) }} - -readWordArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readWordArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, W# r# #) }} - -readAddrArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readAddrArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, A# r# #) }} - -readFloatArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readFloatArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, F# r# #) }} - -readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case readDoubleArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, D# r# #) }} - ---Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here. -indexCharArray :: Ix ix => ByteArray ix -> ix -> Char -indexIntArray :: Ix ix => ByteArray ix -> ix -> Int -indexWordArray :: Ix ix => ByteArray ix -> ix -> Word -indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr -indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float -indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double - -{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-} -{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-} -{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-} ---NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-} -{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-} - -indexCharArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexCharArray# barr# n# of { r# -> - (C# r#)}} - -indexIntArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexIntArray# barr# n# of { r# -> - (I# r#)}} - -indexWordArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexWordArray# barr# n# of { r# -> - (W# r#)}} - -indexAddrArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexAddrArray# barr# n# of { r# -> - (A# r#)}} - -indexFloatArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexFloatArray# barr# n# of { r# -> - (F# r#)}} - -indexDoubleArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexDoubleArray# barr# n# of { r# -> - (D# r#)}} - -writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () -writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () -writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () -writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s () -writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s () -writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () -writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () - -{-# SPECIALIZE writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (), - MutableArray s IPr elt -> IPr -> elt -> ST s () - #-} -{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} -{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} -{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-} ---NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} -{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} - -writeArray (MutableArray ixs arr#) n ele = ST $ \ s# -> - case index ixs n of { I# n# -> - case writeArray# arr# n# ele s# of { s2# -> - (# s2#, () #) }} -writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeCharArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} -writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeIntArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} +boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix) +{-# SPECIALIZE boundsSTArray :: STArray s Int elt -> IPr #-} +boundsSTArray (STArray l u _) = (l,u) -writeWordArray (MutableByteArray ixs barr#) n (W# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeWordArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} +readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt +{-# SPECIALIZE readSTArray :: STArray s Int elt -> Int -> ST s elt, + STArray s IPr elt -> IPr -> ST s elt + #-} -writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeAddrArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} +readSTArray (STArray l u arr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readArray# arr# n# s# of { (# s2#, r #) -> + (# s2#, r #) }} -writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeFloatArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} +writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s () +{-# SPECIALIZE writeSTArray :: STArray s Int elt -> Int -> elt -> ST s (), + STArray s IPr elt -> IPr -> elt -> ST s () + #-} -writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeDoubleArray# barr# n# ele s# of { s2# -> +writeSTArray (STArray l u arr#) n ele = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeArray# arr# n# ele s# of { s2# -> (# s2#, () #) }} \end{code} @@ -428,30 +530,23 @@ writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# -> %********************************************************* \begin{code} -{- -freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt), - MutableArray s IPr elt -> ST s (Array IPr elt) +freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt) +{-# SPECIALISE freezeSTArray :: STArray s Int elt -> ST s (Array Int elt), + STArray s IPr elt -> ST s (Array IPr elt) #-} -{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} --} -freezeArray (MutableArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> + +freezeSTArray (STArray l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, Array ixs frozen# #) }} + (# s2#, Array l u frozen# #) }} where freeze :: MutableArray# s ele -- the thing -> Int# -- size of thing to be frozen -> State# s -- the Universe and everything -> (# State# s, Array# ele #) - freeze arr# n# s# + freeze m_arr# n# s# = case newArray# n# init s# of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeArray# newarr2# s3# }} where @@ -463,173 +558,43 @@ freezeArray (MutableArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableArray# s ele #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case readArray# from# cur# s# of { (# s1#, ele #) -> + = case readArray# from# cur# st# of { (# s1#, ele #) -> case writeArray# to# cur# ele s1# of { s2# -> copy (cur# +# 1#) end# from# to# s2# }} -freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray ixs frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze arr# n# s# - = case (newCharArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# s# - | cur# ==# end# - = (# s#, to# #) - | otherwise - = case (readCharArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeCharArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray ixs frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze arr# n# s# - = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# s# - | cur# ==# end# - = (# s#, to# #) - | otherwise - = case (readIntArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeIntArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeWordArray (MutableByteArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray ixs frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze arr# n# s# - = case (newWordArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# s# - | cur# ==# end# - = (# s#, to# #) - | otherwise - = case (readWordArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeWordArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray ixs frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze arr# n# s# - = case (newAddrArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# s# - | cur# ==# end# - = (# s#, to# #) - | otherwise - = case (readAddrArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeAddrArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) - #-} - -unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ s# -> +unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt) +unsafeFreezeSTArray (STArray l u arr#) = ST $ \ s# -> case unsafeFreezeArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, Array ixs frozen# #) } - -unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray ixs frozen# #) } - + (# s2#, Array l u frozen# #) } --This takes a immutable array, and copies it into a mutable array, in a --hurry. -{-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt), - Array IPr elt -> ST s (MutableArray s IPr elt) +thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) +{-# SPECIALISE thawSTArray :: Array Int elt -> ST s (STArray s Int elt), + Array IPr elt -> ST s (STArray s IPr elt) #-} -thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) -thawArray (Array ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> +thawSTArray (Array l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> case thaw arr# n# s# of { (# s2#, thawed# #) -> - (# s2#, MutableArray ixs thawed# #)}} + (# s2#, STArray l u thawed# #)}} where thaw :: Array# ele -- the thing -> Int# -- size of thing to be thawed -> State# s -- the Universe and everything -> (# State# s, MutableArray# s ele #) - thaw arr# n# s# + thaw arr1# n# s# = case newArray# n# init s# of { (# s2#, newarr1# #) -> - copy 0# n# arr# newarr1# s2# } + copy 0# n# arr1# newarr1# s2# } where - init = error "thawArray: element not copied" + init = error "thawSTArray: element not copied" copy :: Int# -> Int# -> Array# ele @@ -637,13 +602,20 @@ thawArray (Array ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableArray# s ele #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case indexArray# from# cur# of { (# _, ele #) -> - case writeArray# to# cur# ele s# of { s1# -> + = case indexArray# from# cur# of { (# ele #) -> + case writeArray# to# cur# ele st# of { s1# -> copy (cur# +# 1#) end# from# to# s1# }} +-- this is a quicker version of the above, just flipping the type +-- (& representation) of an immutable array. And placing a +-- proof obligation on the programmer. +unsafeThawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) +unsafeThawSTArray (Array l u arr#) = ST $ \ s# -> + case unsafeThawArray# arr# s# of + (# s2#, marr# #) -> (# s2#, STArray l u marr# #) \end{code}