X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelArr.lhs;h=d714ff9f6e32832bc3182c4fc88abdac8c175cee;hb=32a895831dbc202fab780fdd8bee65be81e2d232;hp=e930bad39832614469057b945f7862bc56373b4c;hpb=940841711bb0c30326a5173d8107c2792919641c;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index e930bad..d714ff9 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -1,6 +1,9 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelArr.lhs,v 1.30 2001/09/13 15:54:43 simonmar 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 @@ -14,13 +17,11 @@ For byte-arrays see @PrelByteArr@. module PrelArr where import {-# SOURCE #-} PrelErr ( error ) -import PrelList (foldl) import PrelEnum import PrelNum import PrelST import PrelBase -import PrelAddr -import PrelGHC +import PrelList import PrelShow infixl 9 !, // @@ -36,17 +37,38 @@ default () %********************************************************* \begin{code} -class (Ord a) => Ix a where +class (Ord a) => Ix a where range :: (a,a) -> [a] index, unsafeIndex :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool + rangeSize :: (a,a) -> Int + unsafeRangeSize :: (a,a) -> Int -- 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 + + -- As long as you don't override the default rangeSize, + -- you can specify unsafeRangeSize as follows, to speed up + -- some operations: + -- + -- unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- + rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 + | otherwise = 0 + unsafeRangeSize b = rangeSize b \end{code} +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= fromEnum l && fromEnum i <= fromEnum u + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + ---------------------------------------------------------------------- instance Ix Ordering where -- as derived {-# INLINE range #-} @@ -135,6 +164,8 @@ instance Ix Ordering where -- as derived inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + ---------------------------------------------------------------------- instance Ix () where {-# INLINE range #-} @@ -146,6 +177,7 @@ instance Ix () where {-# INLINE index #-} index b i = unsafeIndex b i + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 ---------------------------------------------------------------------- instance (Ix a, Ix b) => Ix (a, b) where -- as derived @@ -163,6 +195,8 @@ instance (Ix a, Ix b) => Ix (a, b) where -- as derived inRange ((l1,l2),(u1,u2)) (i1,i2) = inRange (l1,u1) i1 && inRange (l2,u2) i2 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index ---------------------------------------------------------------------- @@ -183,6 +217,8 @@ instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index ---------------------------------------------------------------------- @@ -203,6 +239,8 @@ instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 && inRange (l4,u4) i4 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where @@ -225,207 +263,215 @@ instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where 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. + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 -\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 Array ix elt = Array ix ix (Array# elt) -data Ix ix => STArray s ix elt = STArray ix ix (MutableArray# s elt) +newSTRef :: a -> ST s (STRef s a) +newSTRef init = ST $ \s1# -> + case newMutVar# init s1# of { (# s2#, var# #) -> + (# s2#, STRef var# #) } +readSTRef :: STRef s a -> ST s a +readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1# -data STRef s a = STRef (MutVar# s a) +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# - --- just pointer equality on arrays: -instance Eq (STArray s ix elt) where - STArray _ _ arr1# == STArray _ _ arr2# - = sameMutableArray# arr1# arr2# + STRef v1# == STRef v2# = sameMutVar# v1# v2# \end{code} + %********************************************************* %* * -\subsection{Operations on mutable variables} +\subsection{The @Array@ types} %* * %********************************************************* \begin{code} -newSTRef :: a -> ST s (STRef s a) -readSTRef :: STRef s a -> ST s a -writeSTRef :: STRef s a -> a -> ST s () - -newSTRef init = ST $ \ s# -> - case (newMutVar# init s#) of { (# s2#, var# #) -> - (# s2#, STRef var# #) } +type IPr = (Int, Int) -readSTRef (STRef var#) = ST $ \ s# -> readMutVar# var# s# +data Ix i => Array i e = Array !i !i (Array# e) +data Ix i => STArray s i e = STArray !i !i (MutableArray# s e) -writeSTRef (STRef var#) val = ST $ \ s# -> - case writeMutVar# var# val s# of { s2# -> - (# s2#, () #) } +-- Just pointer equality on mutable arrays: +instance Eq (STArray s i e) where + STArray _ _ arr1# == STArray _ _ arr2# = + sameMutableArray# arr1# arr2# \end{code} + %********************************************************* %* * \subsection{Operations on immutable arrays} %* * %********************************************************* -"array", "!" and "bounds" are basic; the rest can be defined in terms of them - \begin{code} -bounds :: (Ix a) => Array a b -> (a,a) -{-# INLINE bounds #-} -bounds (Array l u _) = (l,u) - -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 +{-# NOINLINE arrEleBottom #-} +arrEleBottom :: a +arrEleBottom = error "(Array.!): undefined array element" -{-# 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 +{-# 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# }}) -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 }} +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# } -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 #) } +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 -arrEleBottom :: a -arrEleBottom = error "(Array.!): undefined array element" +{-# 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) ------------------------------------------------------------------------ --- These also go better with magic: (//), accum, accumArray --- *** NB *** We INLINE them all so that their foldr's get to the call site +{-# 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# }} -(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b {-# INLINE (//) #-} -old_array // ivs - = runST (do - -- copy the old array: - arr <- thawSTArray old_array - -- now write the new elements into the new array: - fill_it_in arr ivs - freezeSTArray arr - ) - -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 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 <- thawSTArray old_array - -- now zap the elements in question with "f": - zap_with_f f arr ivs - freezeSTArray arr - ) +(//) :: 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)) -accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b -{-# INLINE accumArray #-} -accumArray f zero ixs ivs - = runST (do - arr <- newSTArray ixs zero - zap_with_f f arr ivs - freezeSTArray arr - ) +{-# INLINE accum #-} +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} @@ -435,24 +481,23 @@ accumArray f zero ixs ivs %* * %********************************************************* - \begin{code} -instance Ix a => Functor (Array a) where - fmap = amap +instance Ix i => Functor (Array i) 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 i, Eq e) => Eq (Array i e) where + (==) = eqArray -instance (Ix a, Ord b) => Ord (Array a b) where - compare a b = compare (assocs a) (assocs b) +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) ) - showList = showList__ (showsPrec 0) +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 @@ -460,7 +505,6 @@ instance (Ix a, Read a, Read b) => Read (Array a b) where (\r -> [(array b as, u) | ("array",s) <- lex r, (b,t) <- reads s, (as,u) <- reads t ]) - readList = readList__ (readsPrec 0) -} \end{code} @@ -485,41 +529,37 @@ it frequently. Now we've got the overloading specialiser things might be different, though. \begin{code} -newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt) - -{-# SPECIALIZE newSTArray :: IPr -> elt -> ST s (STArray s Int elt), - (IPr,IPr) -> elt -> ST s (STArray s IPr elt) - #-} -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# #) }} - - - -boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix) -{-# SPECIALIZE boundsSTArray :: STArray s Int elt -> IPr #-} -boundsSTArray (STArray l u _) = (l,u) - -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 - #-} - -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 #) }} - -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 () - #-} - -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#, () #) }} +{-# 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} @@ -530,92 +570,40 @@ writeSTArray (STArray l u arr#) n ele = ST $ \ s# -> %********************************************************* \begin{code} -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) - #-} - -freezeSTArray (STArray l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case freeze arr# n# s# of { (# s2#, 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 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# - }} - -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 l u frozen# #) } - ---This takes a immutable array, and copies it into a mutable array, in a ---hurry. - -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) - #-} - -thawSTArray (Array l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case thaw arr# n# s# of { (# s2#, 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 arr1# n# s# - = case newArray# n# init s# of { (# s2#, newarr1# #) -> - copy 0# n# arr1# newarr1# s2# } - where - init = error "thawSTArray: 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. -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# #) +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}