X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelArr.lhs;h=450898a6cda5dfe72f221a3ceed114de0a39b749;hb=225d251337438e2f7870f0ec2781b1c616ef7462;hp=8165fac1ff80fa0f0905e3c3dddccacf34bdae36;hpb=9d38678ea60ff32f756390a30c659daa22c98c93;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index 8165fac..450898a 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -1,199 +1,505 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelArr.lhs,v 1.28 2001/05/01 09:16:56 qrczak Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The University of Glasgow, 1994-2000 % + \section[PrelArr]{Module @PrelArr@} 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 PrelList +import PrelShow infixl 9 !, // -\end{code} - -\begin{code} -{-# SPECIALISE array :: (Int,Int) -> [(Int,b)] -> Array Int b #-} -array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b - -{-# 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) +default () +\end{code} -{-# SPECIALISE (//) :: Array Int b -> [(Int,b)] -> Array Int b #-} -(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b -{-# 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 +%********************************************************* +%* * +\subsection{The @Ix@ class} +%* * +%********************************************************* -{-# 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 +\begin{code} +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} %********************************************************* %* * -\subsection{The @Array@ types} +\subsection{Instances of @Ix@} %* * %********************************************************* \begin{code} -type IPr = (Int, Int) +-- abstract these errors from the relevant index functions so that +-- the guts of the function will be small enough to inline. + +{-# 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) "") + +---------------------------------------------------------------------- +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)) -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) + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 -instance CCallable (MutableByteArray s ix) -instance CCallable (MutableByteArray# s) + -- Default method for index -instance CCallable (ByteArray ix) -instance CCallable ByteArray# +---------------------------------------------------------------------- +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)] -data MutableVar s a = MutableVar (MutVar# s a) + 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))) -instance Eq (MutableVar s a) where - MutableVar v1# == MutableVar v2# - = sameMutVar# v1# v2# + 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 --- just pointer equality on arrays: -instance Eq (MutableArray s ix elt) where - MutableArray _ arr1# == MutableArray _ arr2# - = sameMutableArray# arr1# arr2# + -- Default method for index -instance Eq (MutableByteArray s ix) where - MutableByteArray _ arr1# == MutableByteArray _ arr2# - = sameMutableByteArray# arr1# arr2# +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 ST s (MutableVar s a) -readVar :: MutableVar s a -> ST s a -writeVar :: MutableVar s a -> a -> ST s () +data STRef s a = STRef (MutVar# s a) -newVar init = ST $ \ s# -> - case (newMutVar# init s#) of { (# s2#, var# #) -> - (# s2#, MutableVar var# #) } +newSTRef :: a -> ST s (STRef s a) +newSTRef init = ST $ \s1# -> + case newMutVar# init s1# of { (# s2#, var# #) -> + (# s2#, STRef var# #) } -readVar (MutableVar var#) = ST $ \ s# -> readMutVar# var# s# +readSTRef :: STRef s a -> ST s a +readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1# -writeVar (MutableVar var#) val = ST $ \ s# -> - case writeMutVar# var# val s# of { s2# -> +writeSTRef :: STRef s a -> a -> ST s () +writeSTRef (STRef var#) val = ST $ \s1# -> + case writeMutVar# var# val s1# of { s2# -> (# s2#, () #) } + +-- Just pointer equality on mutable references: +instance Eq (STRef s a) where + STRef v1# == STRef v2# = sameMutVar# v1# v2# \end{code} + %********************************************************* %* * -\subsection{Operations on immutable arrays} +\subsection{The @Array@ types} %* * %********************************************************* -"array", "!" and "bounds" are basic; the rest can be defined in terms of them - \begin{code} -bounds (Array b _) = b +type IPr = (Int, Int) -(Array bounds arr#) ! i - = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range - in - case (indexArray# arr# n#) of - (# v #) -> v +data Ix i => Array i e = Array !i !i (Array# e) +data Ix i => STArray s i e = STArray !i !i (MutableArray# s e) -{-# 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 }} +-- Just pointer equality on mutable arrays: +instance Eq (STArray s i e) where + STArray _ _ arr1# == STArray _ _ arr2# = + sameMutableArray# arr1# arr2# +\end{code} -done :: Ix ix => (ix,ix) -> MutableArray# s elt - -> STRep s (Array ix elt) -{-# INLINE done #-} -done ixs marr = \s1 -> case unsafeFreezeArray# marr s1 of { (# s2, arr #) -> - (# s2, Array ixs arr #) } +%********************************************************* +%* * +\subsection{Operations on immutable arrays} +%* * +%********************************************************* + +\begin{code} +{-# NOINLINE arrEleBottom #-} arrEleBottom :: a arrEleBottom = error "(Array.!): undefined array element" +{-# INLINE array #-} +array :: Ix i => (i,i) -> [(i, e)] -> Array i e +array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE unsafeArray #-} +unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e +unsafeArray (l,u) ies = runST (ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> + foldr (fill marr#) (done l u marr#) ies s2# }}) ------------------------------------------------------------------------ --- These also go better with magic: (//), accum, accumArray --- *** NB *** We INLINE them all so that their foldr's get to the call site +{-# INLINE fill #-} +fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a +fill marr# (I# i#, e) next s1# = + case writeArray# marr# i# e s1# of { s2# -> + next s2# } + +{-# INLINE done #-} +done :: Ix i => i -> i -> MutableArray# s e -> STRep s (Array i e) +done l u marr# s1# = + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, Array l u arr# #) } + +-- This is inefficient and I'm not sure why: +-- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es) +-- The code below is better. It still doesn't enable foldr/build +-- transformation on the list of elements; I guess it's impossible +-- using mechanisms currently available. + +{-# INLINE listArray #-} +listArray :: Ix i => (i,i) -> [e] -> Array i e +listArray (l,u) es = runST (ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> + let fillFromList i# xs s3# | i# ==# n# = s3# + | otherwise = case xs of + [] -> s3# + y:ys -> case writeArray# marr# i# y s3# of { s4# -> + fillFromList (i# +# 1#) ys s4# } in + case fillFromList 0# es s2# of { s3# -> + done l u marr# s3# }}}) + +{-# INLINE (!) #-} +(!) :: Ix i => Array i e -> i -> e +arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i) + +{-# INLINE unsafeAt #-} +unsafeAt :: Ix i => Array i e -> Int -> e +unsafeAt (Array _ _ arr#) (I# i#) = + case indexArray# arr# i# of (# e #) -> e + +{-# INLINE bounds #-} +bounds :: Ix i => Array i e -> (i,i) +bounds (Array l u _) = (l,u) + +{-# INLINE indices #-} +indices :: Ix i => Array i e -> [i] +indices (Array l u _) = range (l,u) + +{-# INLINE elems #-} +elems :: Ix i => Array i e -> [e] +elems arr@(Array l u _) = + [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]] + +{-# INLINE assocs #-} +assocs :: Ix i => Array i e -> [(i, e)] +assocs arr@(Array l u _) = + [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)] + +{-# INLINE accumArray #-} +accumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(i, a)] -> Array i e +accumArray f init (l,u) ies = + unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE unsafeAccumArray #-} +unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e +unsafeAccumArray f init (l,u) ies = runST (ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# init s1# of { (# s2#, marr# #) -> + foldr (adjust f marr#) (done l u marr#) ies s2# }}) + +{-# INLINE adjust #-} +adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b +adjust f marr# (I# i#, new) next s1# = + case readArray# marr# i# s1# of { (# s2#, old #) -> + case writeArray# marr# i# (f old new) s2# of { s3# -> + next s3# }} {-# INLINE (//) #-} -old_array // ivs - = runST (do - -- copy the old array: - arr <- thawArray old_array - -- now write the new elements into the new array: - fill_it_in arr ivs - freezeArray arr - ) - -fill_it_in :: Ix ix => MutableArray 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 = writeArray arr i v >> rst - -zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray 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 f arr) (return ()) lst - -zap_one f arr (i, new_v) rst = do - old_v <- readArray arr i - writeArray arr i (f old_v new_v) - rst +(//) :: Ix i => Array i e -> [(i, e)] -> Array i e +arr@(Array l u _) // ies = + unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE unsafeReplace #-} +unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e +unsafeReplace arr@(Array l u _) ies = runST (do + STArray _ _ marr# <- thawSTArray arr + ST (foldr (fill marr#) (done l u marr#) ies)) {-# INLINE accum #-} -accum f old_array ivs - = runST (do - -- copy the old array: - arr <- thawArray old_array - -- now zap the elements in question with "f": - zap_with_f f arr ivs - freezeArray arr - ) +accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e +accum f arr@(Array l u _) ies = + unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE unsafeAccum #-} +unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e +unsafeAccum f arr@(Array l u _) ies = runST (do + STArray _ _ marr# <- thawSTArray arr + ST (foldr (adjust f marr#) (done l u marr#) ies)) + +{-# INLINE amap #-} +amap :: Ix i => (a -> b) -> Array i a -> Array i b +amap f arr@(Array l u _) = + unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]] + +{-# INLINE ixmap #-} +ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e +ixmap (l,u) f arr = + unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)] + +{-# INLINE eqArray #-} +eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool +eqArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) = + if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else + l1 == l2 && u1 == u2 && + and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]] + +{-# INLINE cmpArray #-} +cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering +cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2) + +{-# INLINE cmpIntArray #-} +cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering +cmpIntArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) = + if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else + if rangeSize (l2,u2) == 0 then GT else + case compare l1 l2 of + EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1] + other -> other + where + cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of + EQ -> rest + other -> other + +{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-} +\end{code} -{-# INLINE accumArray #-} -accumArray f zero ixs ivs - = runST (do - arr <- newArray ixs zero - zap_with_f f arr ivs - freezeArray arr - ) + +%********************************************************* +%* * +\subsection{Array instances} +%* * +%********************************************************* + +\begin{code} +instance Ix i => Functor (Array i) where + fmap = amap + +instance (Ix i, Eq e) => Eq (Array i e) where + (==) = eqArray + +instance (Ix i, Ord e) => Ord (Array i e) where + compare = cmpArray + +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) + +{- +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 ]) +-} \end{code} @@ -204,7 +510,7 @@ accumArray f zero ixs ivs %********************************************************* 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 @@ -217,209 +523,37 @@ 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, newWordArray, newAddrArray, newFloatArray, newDoubleArray - :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) - -{-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), - (IPr,IPr) -> elt -> ST s (MutableArray 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) - -{-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-} - -boundsOfArray (MutableArray 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 #) }} - -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#, () #) }} - -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#, () #) }} - -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#, () #) }} - -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#, () #) }} - -writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# -> - case (index ixs n) of { I# n# -> - case writeDoubleArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} +{-# INLINE newSTArray #-} +newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) +newSTArray (l,u) init = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# init s1# of { (# s2#, marr# #) -> + (# s2#, STArray l u marr# #) }} + +{-# INLINE boundsSTArray #-} +boundsSTArray :: STArray s i e -> (i,i) +boundsSTArray (STArray l u _) = (l,u) + +{-# INLINE readSTArray #-} +readSTArray :: Ix i => STArray s i e -> i -> ST s e +readSTArray marr@(STArray l u _) i = + unsafeReadSTArray marr (index (l,u) i) + +{-# INLINE unsafeReadSTArray #-} +unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e +unsafeReadSTArray (STArray _ _ marr#) (I# i#) = ST $ \s1# -> + readArray# marr# i# s1# + +{-# INLINE writeSTArray #-} +writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () +writeSTArray marr@(STArray l u _) i e = + unsafeWriteSTArray marr (index (l,u) i) e + +{-# INLINE unsafeWriteSTArray #-} +unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s () +unsafeWriteSTArray (STArray _ _ marr#) (I# i#) e = ST $ \s1# -> + case writeArray# marr# i# e s1# of { s2# -> + (# s2#, () #) } \end{code} @@ -430,227 +564,40 @@ 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) - #-} -{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} - -freezeArray (MutableArray ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, Array ixs 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 m_arr# n# s# - = case newArray# n# init s# of { (# s2#, newarr1# #) -> - case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeArray# newarr2# s3# - }} - where - init = error "freezeArray: element not copied" - - copy :: Int# -> Int# - -> MutableArray# s ele - -> MutableArray# s ele - -> State# s - -> (# State# s, MutableArray# s ele #) - - copy cur# end# from# to# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = 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 arr1# n# s1# - = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr1# 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# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = case (readCharArray# from# cur# st#) of { (# s2#, ele #) -> - case (writeCharArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -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 m_arr# n# s# - = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_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# s1# - | cur# ==# end# - = (# s1#, to# #) - | otherwise - = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) -> - case (writeIntArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -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 m_arr# n# s1# - = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_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# st# - | cur# ==# end# = (# st#, to# #) - | otherwise = - case (readWordArray# from# cur# st#) of { (# s2#, ele #) -> - case (writeWordArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -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 m_arr# n# s1# - = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_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# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) -> - case (writeAddrArray# to# cur# ele st1#) of { st2# -> - copy (cur# +# 1#) end# from# to# st2# - }} - -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# -> - 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# #) } - - ---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) - #-} - -thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) -thawArray (Array ixs arr#) = ST $ \ s# -> - case rangeSize ixs of { I# n# -> - case thaw arr# n# s# of { (# s2#, thawed# #) -> - (# s2#, MutableArray ixs 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 arr1# n# s# - = case newArray# n# init s# of { (# s2#, newarr1# #) -> - copy 0# n# arr1# newarr1# s2# } - where - init = error "thawArray: element not copied" - - copy :: Int# -> Int# - -> Array# ele - -> MutableArray# s ele - -> State# s - -> (# State# s, MutableArray# s ele #) - - copy cur# end# from# to# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = 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. -unsafeThawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) -unsafeThawArray (Array ixs arr#) = ST $ \ s# -> - case unsafeThawArray# arr# s# of - (# s2#, marr# #) -> (# s2#, MutableArray ixs marr# #) +freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) +freezeSTArray (STArray l u marr#) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) -> + let copy i# s3# | i# ==# n# = s3# + | otherwise = + case readArray# marr# i# s3# of { (# s4#, e #) -> + case writeArray# marr'# i# e s4# of { s5# -> + copy (i# +# 1#) s5# }} in + case copy 0# s2# of { s3# -> + case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) -> + (# s4#, Array l u arr# #) }}}} + +{-# INLINE unsafeFreezeSTArray #-} +unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) +unsafeFreezeSTArray (STArray l u marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, Array l u arr# #) } + +thawSTArray :: Ix i => Array i e -> ST s (STArray s i e) +thawSTArray (Array l u arr#) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> + let copy i# s3# | i# ==# n# = s3# + | otherwise = + case indexArray# arr# i# of { (# e #) -> + case writeArray# marr# i# e s3# of { s4# -> + copy (i# +# 1#) s4# }} in + case copy 0# s2# of { s3# -> + (# s3#, STArray l u marr# #) }}} + +{-# INLINE unsafeThawSTArray #-} +unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e) +unsafeThawSTArray (Array l u arr#) = ST $ \s1# -> + case unsafeThawArray# arr# s1# of { (# s2#, marr# #) -> + (# s2#, STArray l u marr# #) } \end{code}