ghc/lib/glaExts/PreludeGlaST.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994
   3 %
   4 \section[PreludeGlaST]{Basic ``state transformer'' monad, mutable arrays and variables}
   5
   6 See state-interface.verb, from which this is taken directly.
   7
   8 \begin{code}
   9 #include "../../includes/platform.h"
  10 #include "../../includes/GhcConstants.h"
  11
  12 module PreludeGlaST (
  13         PreludeGlaST.. ,
  14         _MutableArray(..),
  15         _MutableByteArray(..),
  16         ST(..),         -- it's a known GHC infelicity that synonyms must
  17         MutableVar(..), -- be listed separately.
  18
  19         --!! because this interface is now the "everything state-transformer"ish
  20         --!! interface, here is all the PreludePrimIO stuff
  21
  22         -- PrimIO(..): no, the compiler already knows about it
  23
  24         fixPrimIO,
  25         listPrimIO,
  26         mapAndUnzipPrimIO,
  27         mapPrimIO,
  28         returnPrimIO,
  29         seqPrimIO,
  30         thenPrimIO,
  31         unsafePerformPrimIO,
  32         unsafeInterleavePrimIO,
  33         forkPrimIO,
  34
  35         -- all the Stdio stuff (this is how you get to it)
  36         -- (well, why not?)
  37         fclose, fdopen, fflush, fopen, fread, freopen,
  38         fwrite, _FILE(..),
  39
  40         -- backward compatibility -- don't use!
  41         readChanPrimIO,
  42         appendChanPrimIO,
  43         appendFilePrimIO,
  44         getArgsPrimIO,
  45
  46         --!! end of PreludePrimIO
  47
  48         _ByteArray(..), Array(..) -- reexport *unabstractly*
  49     ) where
  50
  51 import PreludePrimIO    (
  52         fixPrimIO,
  53         listPrimIO,
  54         mapAndUnzipPrimIO,
  55         mapPrimIO,
  56         returnPrimIO,
  57         seqPrimIO,
  58         thenPrimIO,
  59         unsafePerformPrimIO,
  60         unsafeInterleavePrimIO,
  61 --      forkPrimIO,
  62         readChanPrimIO,
  63         appendChanPrimIO,
  64         appendFilePrimIO,
  65         getArgsPrimIO
  66         )
  67 import Stdio
  68
  69 import Cls
  70 import Core
  71 import IInt
  72 import ITup2
  73 import List             ( map, null, foldr, (++) )
  74 import PS               ( _PackedString, _unpackPS )
  75 import TyArray          ( Array(..), _ByteArray(..) )
  76 import TyComplex
  77 import Text
  78
  79 infixr 9 `thenST`, `thenStrictlyST`, `seqST`, `seqStrictlyST`
  80
  81 type IPr = (Int, Int)
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection[PreludeGlaST-ST-monad]{The state-transformer proper}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 --BUILT-IN: type _ST s a        -- State transformer
  92
  93 type ST s a = _ST s a   -- so you don't need -fglasgow-exts
  94
  95 {-# INLINE returnST #-}
  96 {-# INLINE returnStrictlyST #-}
  97 {-# INLINE thenStrictlyST #-}
  98 {-# INLINE seqStrictlyST #-}
  99
 100 returnST :: a -> _ST s a
 101 returnST a s = (a, s)
 102
 103 thenST :: _ST s a -> (a -> _ST s b) -> _ST s b
 104 thenST m k s = let (r,new_s) = m s
 105                in
 106                k r new_s
 107
 108 seqST :: _ST s a -> _ST s b -> _ST s b
 109 seqST m1 m2 = m1 `thenST` (\ _ -> m2)
 110
 111
 112 {-# GENERATE_SPECS returnStrictlyST a #-}
 113 returnStrictlyST :: a -> _ST s a
 114
 115 {-# GENERATE_SPECS thenStrictlyST a b #-}
 116 thenStrictlyST :: _ST s a -> (a -> _ST s b) -> _ST s b
 117
 118 {-# GENERATE_SPECS seqStrictlyST a b #-}
 119 seqStrictlyST :: _ST s a -> _ST s b -> _ST s b
 120
 121
 122 returnStrictlyST a s@(S# _) = (a, s)
 123
 124 thenStrictlyST m k s    -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
 125   = case (m s) of { (r, new_s) ->
 126     k r new_s }
 127
 128 seqStrictlyST m k s     -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
 129   = case (m s) of { (_, new_s) ->
 130     k new_s }
 131
 132
 133 -- BUILT-IN: _runST (see Builtin.hs)
 134
 135 unsafeInterleaveST :: _ST s a -> _ST s a    -- ToDo: put in state-interface.tex
 136 unsafeInterleaveST m s
 137   = let
 138         (r, new_s) = m s
 139     in
 140     (r, s)
 141
 142
 143 fixST :: (a -> _ST s a) -> _ST s a
 144 fixST k s = let ans = k r s
 145                 (r,new_s) = ans
 146             in
 147             ans
 148
 149 listST :: [_ST s a] -> _ST s [a]
 150 listST []     = returnST []
 151 listST (m:ms) = m               `thenST` \ x  ->
 152                 listST ms       `thenST` \ xs ->
 153                 returnST (x:xs)
 154
 155 mapST :: (a -> _ST s b) -> [a] -> _ST s [b]
 156 mapST f ms = listST (map f ms)
 157
 158 mapAndUnzipST :: (a -> _ST s (b,c)) -> [a] -> _ST s ([b],[c])
 159 mapAndUnzipST f [] = returnST ([], [])
 160 mapAndUnzipST f (m:ms)
 161   = f m                 `thenST` \ ( r1,  r2) ->
 162     mapAndUnzipST f ms  `thenST` \ (rs1, rs2) ->
 163     returnST (r1:rs1, r2:rs2)
 164
 165 forkST :: ST s a -> ST s a
 166
 167 #ifndef __CONCURRENT_HASKELL__
 168 forkST x = x
 169 #else
 170
 171 forkST action s
 172  = let
 173     (r, new_s) = action s
 174    in
 175     new_s `_fork_` (r, s)
 176  where
 177     _fork_ x y = case (fork# x) of { 0# -> parError#; _ -> y }
 178
 179 #endif {- concurrent -}
 180
 181 forkPrimIO :: PrimIO a -> PrimIO a
 182 forkPrimIO = forkST
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection[PreludeGlaST-arrays]{Mutable arrays}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 Idle ADR question: What's the tradeoff here between flattening these
 192 datatypes into @_MutableArray ix ix (MutableArray# s elt)@ and using
 193 it as is?  As I see it, the former uses slightly less heap and
 194 provides faster access to the individual parts of the bounds while the
 195 code used has the benefit of providing a ready-made @(lo, hi)@ pair as
 196 required by many array-related functions.  Which wins? Is the
 197 difference significant (probably not).
 198
 199 Idle AJG answer: When I looked at the outputted code (though it was 2
 200 years ago) it seems like you often needed the tuple, and we build
 201 it frequently. Now we've got the overloading specialiser things
 202 might be different, though.
 203
 204 \begin{code}
 205 data _MutableArray     s ix elt = _MutableArray     (ix,ix) (MutableArray# s elt)
 206 data _MutableByteArray s ix     = _MutableByteArray (ix,ix) (MutableByteArray# s)
 207
 208 instance _CCallable (_MutableByteArray s ix)
 209 \end{code}
 210
 211 \begin{code}
 212 newArray    :: Ix ix => (ix,ix) -> elt -> _ST s (_MutableArray s ix elt)
 213 newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray
 214             :: Ix ix => (ix,ix) -> _ST s (_MutableByteArray s ix)
 215
 216 {-# SPECIALIZE newArray       :: IPr       -> elt -> _ST s (_MutableArray s Int elt),
 217                                  (IPr,IPr) -> elt -> _ST s (_MutableArray s IPr elt)
 218   #-}
 219 {-# SPECIALIZE newCharArray   :: IPr -> _ST s (_MutableByteArray s Int) #-}
 220 {-# SPECIALIZE newIntArray    :: IPr -> _ST s (_MutableByteArray s Int) #-}
 221 {-# SPECIALIZE newAddrArray   :: IPr -> _ST s (_MutableByteArray s Int) #-}
 222 {-# SPECIALIZE newFloatArray  :: IPr -> _ST s (_MutableByteArray s Int) #-}
 223 {-# SPECIALIZE newDoubleArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
 224
 225 newArray ixs@(ix_start, ix_end) init (S# s#)
 226   = let n# = case (if null (range ixs)
 227                   then 0
 228                   else (index ixs ix_end) + 1) of { I# x -> x }
 229         -- size is one bigger than index of last elem
 230     in
 231     case (newArray# n# init s#)     of { StateAndMutableArray# s2# arr# ->
 232     (_MutableArray ixs arr#, S# s2#)}
 233
 234 newCharArray ixs@(ix_start, ix_end) (S# s#)
 235   = let n# = case (if null (range ixs)
 236                   then 0
 237                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 238     in
 239     case (newCharArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 240     (_MutableByteArray ixs barr#, S# s2#)}
 241
 242 newIntArray ixs@(ix_start, ix_end) (S# s#)
 243   = let n# = case (if null (range ixs)
 244                   then 0
 245                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 246     in
 247     case (newIntArray# n# s#)     of { StateAndMutableByteArray# s2# barr# ->
 248     (_MutableByteArray ixs barr#, S# s2#)}
 249
 250 newAddrArray ixs@(ix_start, ix_end) (S# s#)
 251   = let n# = case (if null (range ixs)
 252                   then 0
 253                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 254     in
 255     case (newAddrArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 256     (_MutableByteArray ixs barr#, S# s2#)}
 257
 258 newFloatArray ixs@(ix_start, ix_end) (S# s#)
 259   = let n# = case (if null (range ixs)
 260                   then 0
 261                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 262     in
 263     case (newFloatArray# n# s#)   of { StateAndMutableByteArray# s2# barr# ->
 264     (_MutableByteArray ixs barr#, S# s2#)}
 265
 266 newDoubleArray ixs@(ix_start, ix_end) (S# s#)
 267   = let n# = case (if null (range ixs)
 268                   then 0
 269                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 270     in
 271 --    trace ("newDoubleArray:"++(show (I# n#))) (
 272     case (newDoubleArray# n# s#)  of { StateAndMutableByteArray# s2# barr# ->
 273     (_MutableByteArray ixs barr#, S# s2#)}
 274 --    )
 275 \end{code}
 276
 277 \begin{code}
 278 boundsOfArray     :: Ix ix => _MutableArray s ix elt -> (ix, ix)
 279 boundsOfByteArray :: Ix ix => _MutableByteArray s ix -> (ix, ix)
 280
 281 {-# SPECIALIZE boundsOfArray     :: _MutableArray s Int elt -> IPr #-}
 282 {-# SPECIALIZE boundsOfByteArray :: _MutableByteArray s Int -> IPr #-}
 283
 284 boundsOfArray     (_MutableArray     ixs _) = ixs
 285 boundsOfByteArray (_MutableByteArray ixs _) = ixs
 286 \end{code}
 287
 288 \begin{code}
 289 readArray       :: Ix ix => _MutableArray s ix elt -> ix -> _ST s elt
 290
 291 readCharArray   :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Char
 292 readIntArray    :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Int
 293 readAddrArray   :: Ix ix => _MutableByteArray s ix -> ix -> _ST s _Addr
 294 readFloatArray  :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Float
 295 readDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Double
 296
 297 {-# SPECIALIZE readArray       :: _MutableArray s Int elt -> Int -> _ST s elt,
 298                                   _MutableArray s IPr elt -> IPr -> _ST s elt
 299   #-}
 300 {-# SPECIALIZE readCharArray   :: _MutableByteArray s Int -> Int -> _ST s Char #-}
 301 {-# SPECIALIZE readIntArray    :: _MutableByteArray s Int -> Int -> _ST s Int #-}
 302 {-# SPECIALIZE readAddrArray   :: _MutableByteArray s Int -> Int -> _ST s _Addr #-}
 303 --NO:{-# SPECIALIZE readFloatArray  :: _MutableByteArray s Int -> Int -> _ST s Float #-}
 304 {-# SPECIALIZE readDoubleArray :: _MutableByteArray s Int -> Int -> _ST s Double #-}
 305
 306 readArray (_MutableArray ixs arr#) n (S# s#)
 307   = case (index ixs n)          of { I# n# ->
 308     case readArray# arr# n# s#  of { StateAndPtr# s2# r ->
 309     (r, S# s2#)}}
 310
 311 readCharArray (_MutableByteArray ixs barr#) n (S# s#)
 312   = case (index ixs n)                  of { I# n# ->
 313     case readCharArray# barr# n# s#     of { StateAndChar# s2# r# ->
 314     (C# r#, S# s2#)}}
 315
 316 readIntArray (_MutableByteArray ixs barr#) n (S# s#)
 317   = case (index ixs n)                  of { I# n# ->
 318     case readIntArray# barr# n# s#      of { StateAndInt# s2# r# ->
 319     (I# r#, S# s2#)}}
 320
 321 readAddrArray (_MutableByteArray ixs barr#) n (S# s#)
 322   = case (index ixs n)                  of { I# n# ->
 323     case readAddrArray# barr# n# s#     of { StateAndAddr# s2# r# ->
 324     (A# r#, S# s2#)}}
 325
 326 readFloatArray (_MutableByteArray ixs barr#) n (S# s#)
 327   = case (index ixs n)                  of { I# n# ->
 328     case readFloatArray# barr# n# s#    of { StateAndFloat# s2# r# ->
 329     (F# r#, S# s2#)}}
 330
 331 readDoubleArray (_MutableByteArray ixs barr#) n (S# s#)
 332   = case (index ixs n)                  of { I# n# ->
 333 --    trace ("readDoubleArray:"++(show (I# n#))) (
 334     case readDoubleArray# barr# n# s#   of { StateAndDouble# s2# r# ->
 335     (D# r#, S# s2#)}}
 336 \end{code}
 337
 338 Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
 339 \begin{code}
 340 indexCharArray   :: Ix ix => _ByteArray ix -> ix -> Char
 341 indexIntArray    :: Ix ix => _ByteArray ix -> ix -> Int
 342 indexAddrArray   :: Ix ix => _ByteArray ix -> ix -> _Addr
 343 indexFloatArray  :: Ix ix => _ByteArray ix -> ix -> Float
 344 indexDoubleArray :: Ix ix => _ByteArray ix -> ix -> Double
 345
 346 {-# SPECIALIZE indexCharArray   :: _ByteArray Int -> Int -> Char #-}
 347 {-# SPECIALIZE indexIntArray    :: _ByteArray Int -> Int -> Int #-}
 348 {-# SPECIALIZE indexAddrArray   :: _ByteArray Int -> Int -> _Addr #-}
 349 --NO:{-# SPECIALIZE indexFloatArray  :: _ByteArray Int -> Int -> Float #-}
 350 {-# SPECIALIZE indexDoubleArray :: _ByteArray Int -> Int -> Double #-}
 351
 352 indexCharArray (_ByteArray ixs barr#) n
 353   = case (index ixs n)                  of { I# n# ->
 354     case indexCharArray# barr# n#       of { r# ->
 355     (C# r#)}}
 356
 357 indexIntArray (_ByteArray ixs barr#) n
 358   = case (index ixs n)                  of { I# n# ->
 359     case indexIntArray# barr# n#        of { r# ->
 360     (I# r#)}}
 361
 362 indexAddrArray (_ByteArray ixs barr#) n
 363   = case (index ixs n)                  of { I# n# ->
 364     case indexAddrArray# barr# n#       of { r# ->
 365     (A# r#)}}
 366
 367 indexFloatArray (_ByteArray ixs barr#) n
 368   = case (index ixs n)                  of { I# n# ->
 369     case indexFloatArray# barr# n#      of { r# ->
 370     (F# r#)}}
 371
 372 indexDoubleArray (_ByteArray ixs barr#) n
 373   = case (index ixs n)                  of { I# n# ->
 374 --    trace ("indexDoubleArray:"++(show (I# n#))) (
 375     case indexDoubleArray# barr# n#     of { r# ->
 376     (D# r#)}}
 377 \end{code}
 378
 379 Indexing off @_Addrs@ is similar, and therefore given here.
 380 \begin{code}
 381 indexCharOffAddr   :: _Addr -> Int -> Char
 382 indexIntOffAddr    :: _Addr -> Int -> Int
 383 indexAddrOffAddr   :: _Addr -> Int -> _Addr
 384 indexFloatOffAddr  :: _Addr -> Int -> Float
 385 indexDoubleOffAddr :: _Addr -> Int -> Double
 386
 387 indexCharOffAddr (A# addr#) n
 388   = case n                              of { I# n# ->
 389     case indexCharOffAddr# addr# n#     of { r# ->
 390     (C# r#)}}
 391
 392 indexIntOffAddr (A# addr#) n
 393   = case n                              of { I# n# ->
 394     case indexIntOffAddr# addr# n#      of { r# ->
 395     (I# r#)}}
 396
 397 indexAddrOffAddr (A# addr#) n
 398   = case n                              of { I# n# ->
 399     case indexAddrOffAddr# addr# n#     of { r# ->
 400     (A# r#)}}
 401
 402 indexFloatOffAddr (A# addr#) n
 403   = case n                              of { I# n# ->
 404     case indexFloatOffAddr# addr# n#    of { r# ->
 405     (F# r#)}}
 406
 407 indexDoubleOffAddr (A# addr#) n
 408   = case n                              of { I# n# ->
 409     case indexDoubleOffAddr# addr# n#   of { r# ->
 410     (D# r#)}}
 411 \end{code}
 412
 413 \begin{code}
 414 writeArray       :: Ix ix => _MutableArray s ix elt -> ix -> elt -> _ST s ()
 415 writeCharArray   :: Ix ix => _MutableByteArray s ix -> ix -> Char -> _ST s ()
 416 writeIntArray    :: Ix ix => _MutableByteArray s ix -> ix -> Int  -> _ST s ()
 417 writeAddrArray   :: Ix ix => _MutableByteArray s ix -> ix -> _Addr -> _ST s ()
 418 writeFloatArray  :: Ix ix => _MutableByteArray s ix -> ix -> Float -> _ST s ()
 419 writeDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> Double -> _ST s ()
 420
 421 {-# SPECIALIZE writeArray       :: _MutableArray s Int elt -> Int -> elt -> _ST s (),
 422                                    _MutableArray s IPr elt -> IPr -> elt -> _ST s ()
 423   #-}
 424 {-# SPECIALIZE writeCharArray   :: _MutableByteArray s Int -> Int -> Char -> _ST s () #-}
 425 {-# SPECIALIZE writeIntArray    :: _MutableByteArray s Int -> Int -> Int  -> _ST s () #-}
 426 {-# SPECIALIZE writeAddrArray   :: _MutableByteArray s Int -> Int -> _Addr -> _ST s () #-}
 427 --NO:{-# SPECIALIZE writeFloatArray  :: _MutableByteArray s Int -> Int -> Float -> _ST s () #-}
 428 {-# SPECIALIZE writeDoubleArray :: _MutableByteArray s Int -> Int -> Double -> _ST s () #-}
 429
 430 writeArray (_MutableArray ixs arr#) n ele (S# s#)
 431   = case index ixs n                of { I# n# ->
 432     case writeArray# arr# n# ele s# of { s2# ->
 433     ((), S# s2#)}}
 434
 435 writeCharArray (_MutableByteArray ixs barr#) n (C# ele) (S# s#)
 436   = case (index ixs n)                      of { I# n# ->
 437     case writeCharArray# barr# n# ele s#    of { s2#   ->
 438     ((), S# s2#)}}
 439
 440 writeIntArray (_MutableByteArray ixs barr#) n (I# ele) (S# s#)
 441   = case (index ixs n)                      of { I# n# ->
 442     case writeIntArray# barr# n# ele s#     of { s2#   ->
 443     ((), S# s2#)}}
 444
 445 writeAddrArray (_MutableByteArray ixs barr#) n (A# ele) (S# s#)
 446   = case (index ixs n)                      of { I# n# ->
 447     case writeAddrArray# barr# n# ele s#    of { s2#   ->
 448     ((), S# s2#)}}
 449
 450 writeFloatArray (_MutableByteArray ixs barr#) n (F# ele) (S# s#)
 451   = case (index ixs n)                      of { I# n# ->
 452     case writeFloatArray# barr# n# ele s#   of { s2#   ->
 453     ((), S# s2#)}}
 454
 455 writeDoubleArray (_MutableByteArray ixs barr#) n (D# ele) (S# s#)
 456   = case (index ixs n)                      of { I# n# ->
 457 --    trace ("writeDoubleArray:"++(show (I# n#))) (
 458     case writeDoubleArray# barr# n# ele s#  of { s2#   ->
 459     ((), S# s2#)}}
 460 \end{code}
 461
 462 \begin{code}
 463 freezeArray       :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
 464 freezeCharArray   :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 465 freezeIntArray    :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 466 freezeAddrArray   :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 467 freezeFloatArray  :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 468 freezeDoubleArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 469
 470 {-# SPECIALISE freezeArray :: _MutableArray s Int elt -> _ST s (Array Int elt),
 471                               _MutableArray s IPr elt -> _ST s (Array IPr elt)
 472   #-}
 473 {-# SPECIALISE freezeCharArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int) #-}
 474
 475 freezeArray (_MutableArray ixs@(ix_start, ix_end) arr#) (S# s#)
 476   = let n# = case (if null (range ixs)
 477                   then 0
 478                   else (index ixs ix_end) + 1) of { I# x -> x }
 479     in
 480     case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
 481     (_Array ixs frozen#, S# s2#)}
 482   where
 483     freeze  :: MutableArray# s ele      -- the thing
 484             -> Int#                     -- size of thing to be frozen
 485             -> State# s                 -- the Universe and everything
 486             -> StateAndArray# s ele
 487
 488     freeze arr# n# s#
 489       = case newArray# n# init s#             of { StateAndMutableArray# s2# newarr1# ->
 490         case copy 0# n# arr# newarr1# s2#     of { StateAndMutableArray# s3# newarr2# ->
 491         unsafeFreezeArray# newarr2# s3#
 492         }}
 493       where
 494         init = error "freezeArr: element not copied"
 495
 496         copy :: Int# -> Int#
 497              -> MutableArray# s ele -> MutableArray# s ele
 498              -> State# s
 499              -> StateAndMutableArray# s ele
 500
 501         copy cur# end# from# to# s#
 502           | cur# ==# end#
 503             = StateAndMutableArray# s# to#
 504           | True
 505             = case readArray#  from# cur#     s#  of { StateAndPtr# s1# ele ->
 506               case writeArray# to#   cur# ele s1# of { s2# ->
 507               copy (cur# +# 1#) end# from# to# s2#
 508               }}
 509
 510 freezeCharArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 511   = let n# = case (if null (range ixs)
 512                   then 0
 513                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 514     in
 515     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 516     (_ByteArray ixs frozen#, S# s2#) }
 517   where
 518     freeze  :: MutableByteArray# s      -- the thing
 519             -> Int#                     -- size of thing to be frozen
 520             -> State# s                 -- the Universe and everything
 521             -> StateAndByteArray# s
 522
 523     freeze arr# n# s#
 524       = case (newCharArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 525         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 526         unsafeFreezeByteArray# newarr2# s3#
 527         }}
 528       where
 529         copy :: Int# -> Int#
 530              -> MutableByteArray# s -> MutableByteArray# s
 531              -> State# s
 532              -> StateAndMutableByteArray# s
 533
 534         copy cur# end# from# to# s#
 535           | cur# ==# end#
 536             = StateAndMutableByteArray# s# to#
 537           | True
 538             = case (readCharArray#  from# cur#     s#)  of { StateAndChar# s1# ele ->
 539               case (writeCharArray# to#   cur# ele s1#) of { s2# ->
 540               copy (cur# +# 1#) end# from# to# s2#
 541               }}
 542
 543 freezeIntArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 544   = let n# = case (if null (range ixs)
 545                   then 0
 546                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 547     in
 548     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 549     (_ByteArray ixs frozen#, S# s2#) }
 550   where
 551     freeze  :: MutableByteArray# s      -- the thing
 552             -> Int#                     -- size of thing to be frozen
 553             -> State# s                 -- the Universe and everything
 554             -> StateAndByteArray# s
 555
 556     freeze arr# n# s#
 557       = case (newIntArray# n# s#)          of { StateAndMutableByteArray# s2# newarr1# ->
 558         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 559         unsafeFreezeByteArray# newarr2# s3#
 560         }}
 561       where
 562         copy :: Int# -> Int#
 563              -> MutableByteArray# s -> MutableByteArray# s
 564              -> State# s
 565              -> StateAndMutableByteArray# s
 566
 567         copy cur# end# from# to# s#
 568           | cur# ==# end#
 569             = StateAndMutableByteArray# s# to#
 570           | True
 571             = case (readIntArray#  from# cur#     s#)  of { StateAndInt# s1# ele ->
 572               case (writeIntArray# to#   cur# ele s1#) of { s2# ->
 573               copy (cur# +# 1#) end# from# to# s2#
 574               }}
 575
 576 freezeAddrArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 577   = let n# = case (if null (range ixs)
 578                   then 0
 579                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 580     in
 581     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 582     (_ByteArray ixs frozen#, S# s2#) }
 583   where
 584     freeze  :: MutableByteArray# s      -- the thing
 585             -> Int#                     -- size of thing to be frozen
 586             -> State# s                 -- the Universe and everything
 587             -> StateAndByteArray# s
 588
 589     freeze arr# n# s#
 590       = case (newAddrArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 591         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 592         unsafeFreezeByteArray# newarr2# s3#
 593         }}
 594       where
 595         copy :: Int# -> Int#
 596              -> MutableByteArray# s -> MutableByteArray# s
 597              -> State# s
 598              -> StateAndMutableByteArray# s
 599
 600         copy cur# end# from# to# s#
 601           | cur# ==# end#
 602             = StateAndMutableByteArray# s# to#
 603           | True
 604             = case (readAddrArray#  from# cur#     s#)  of { StateAndAddr# s1# ele ->
 605               case (writeAddrArray# to#   cur# ele s1#) of { s2# ->
 606               copy (cur# +# 1#) end# from# to# s2#
 607               }}
 608
 609 freezeFloatArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 610   = let n# = case (if null (range ixs)
 611                   then 0
 612                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 613     in
 614     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 615     (_ByteArray ixs frozen#, S# s2#) }
 616   where
 617     freeze  :: MutableByteArray# s      -- the thing
 618             -> Int#                     -- size of thing to be frozen
 619             -> State# s                 -- the Universe and everything
 620             -> StateAndByteArray# s
 621
 622     freeze arr# n# s#
 623       = case (newFloatArray# n# s#)        of { StateAndMutableByteArray# s2# newarr1# ->
 624         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 625         unsafeFreezeByteArray# newarr2# s3#
 626         }}
 627       where
 628         copy :: Int# -> Int#
 629              -> MutableByteArray# s -> MutableByteArray# s
 630              -> State# s
 631              -> StateAndMutableByteArray# s
 632
 633         copy cur# end# from# to# s#
 634           | cur# ==# end#
 635             = StateAndMutableByteArray# s# to#
 636           | True
 637             = case (readFloatArray#  from# cur#     s#)  of { StateAndFloat# s1# ele ->
 638               case (writeFloatArray# to#   cur# ele s1#) of { s2# ->
 639               copy (cur# +# 1#) end# from# to# s2#
 640               }}
 641
 642 freezeDoubleArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 643   = let n# = case (if null (range ixs)
 644                   then 0
 645                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 646     in
 647     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 648     (_ByteArray ixs frozen#, S# s2#) }
 649   where
 650     freeze  :: MutableByteArray# s      -- the thing
 651             -> Int#                     -- size of thing to be frozen
 652             -> State# s                 -- the Universe and everything
 653             -> StateAndByteArray# s
 654
 655     freeze arr# n# s#
 656       = case (newDoubleArray# n# s#)       of { StateAndMutableByteArray# s2# newarr1# ->
 657         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 658         unsafeFreezeByteArray# newarr2# s3#
 659         }}
 660       where
 661         copy :: Int# -> Int#
 662              -> MutableByteArray# s -> MutableByteArray# s
 663              -> State# s
 664              -> StateAndMutableByteArray# s
 665
 666         copy cur# end# from# to# s#
 667           | cur# ==# end#
 668             = StateAndMutableByteArray# s# to#
 669           | True
 670             = case (readDoubleArray#  from# cur#     s#)  of { StateAndDouble# s1# ele ->
 671               case (writeDoubleArray# to#   cur# ele s1#) of { s2# ->
 672               copy (cur# +# 1#) end# from# to# s2#
 673               }}
 674 \end{code}
 675
 676 \begin{code}
 677 unsafeFreezeArray     :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
 678 unsafeFreezeByteArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 679
 680 {-# SPECIALIZE unsafeFreezeByteArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
 681   #-}
 682
 683 unsafeFreezeArray (_MutableArray ixs arr#) (S# s#)
 684   = case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
 685     (_Array ixs frozen#, S# s2#) }
 686
 687 unsafeFreezeByteArray (_MutableByteArray ixs arr#) (S# s#)
 688   = case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 689     (_ByteArray ixs frozen#, S# s2#) }
 690 \end{code}
 691
 692 \begin{code}
 693 sameMutableArray     :: _MutableArray s ix elt -> _MutableArray s ix elt -> Bool
 694 sameMutableByteArray :: _MutableByteArray s ix -> _MutableByteArray s ix -> Bool
 695
 696 sameMutableArray (_MutableArray _ arr1#) (_MutableArray _ arr2#)
 697   = sameMutableArray# arr1# arr2#
 698
 699 sameMutableByteArray (_MutableByteArray _ arr1#) (_MutableByteArray _ arr2#)
 700   = sameMutableByteArray# arr1# arr2#
 701 \end{code}
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsection[PreludeGlaST-variables]{Variables}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 \begin{code}
 710 type MutableVar s a = _MutableArray s Int a
 711 \end{code}
 712
 713 \begin{code}
 714 newVar   :: a -> _ST s (MutableVar s a)
 715 readVar  :: MutableVar s a -> _ST s a
 716 writeVar :: MutableVar s a -> a -> _ST s ()
 717 sameVar  :: MutableVar s a -> MutableVar s a -> Bool
 718
 719 {- MUCH GRATUITOUS INEFFICIENCY: WDP 95/09:
 720
 721 newVar init    s = newArray (0,0) init s
 722 readVar v      s = readArray v 0 s
 723 writeVar v val s = writeArray v 0 val s
 724 sameVar v1 v2    = sameMutableArray v1 v2
 725 -}
 726
 727 newVar init (S# s#)
 728   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 729     (_MutableArray vAR_IXS arr#, S# s2#) }
 730   where
 731     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 732
 733 readVar (_MutableArray _ var#) (S# s#)
 734   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 735     (r, S# s2#) }
 736
 737 writeVar (_MutableArray _ var#) val (S# s#)
 738   = case writeArray# var# 0# val s# of { s2# ->
 739     ((), S# s2#) }
 740
 741 sameVar (_MutableArray _ var1#) (_MutableArray _ var2#)
 742   = sameMutableArray# var1# var2#
 743 \end{code}