ghc/lib/glaExts/PreludeGlaST.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   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, _newArray
 213         :: Ix ix => (ix,ix) -> elt -> _ST s (_MutableArray s ix elt)
 214 newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray
 215         :: Ix ix => (ix,ix) -> _ST s (_MutableByteArray s ix)
 216
 217 {-# SPECIALIZE _newArray      :: IPr       -> elt -> _ST s (_MutableArray s Int elt),
 218                                  (IPr,IPr) -> elt -> _ST s (_MutableArray s IPr elt)
 219   #-}
 220 {-# SPECIALIZE newCharArray   :: IPr -> _ST s (_MutableByteArray s Int) #-}
 221 {-# SPECIALIZE newIntArray    :: IPr -> _ST s (_MutableByteArray s Int) #-}
 222 {-# SPECIALIZE newAddrArray   :: IPr -> _ST s (_MutableByteArray s Int) #-}
 223 {-# SPECIALIZE newFloatArray  :: IPr -> _ST s (_MutableByteArray s Int) #-}
 224 {-# SPECIALIZE newDoubleArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
 225
 226 newArray = _newArray
 227
 228 _newArray ixs@(ix_start, ix_end) init (S# s#)
 229   = let n# = case (if null (range ixs)
 230                   then 0
 231                   else (index ixs ix_end) + 1) of { I# x -> x }
 232         -- size is one bigger than index of last elem
 233     in
 234     case (newArray# n# init s#)     of { StateAndMutableArray# s2# arr# ->
 235     (_MutableArray ixs arr#, S# s2#)}
 236
 237 newCharArray ixs@(ix_start, ix_end) (S# s#)
 238   = let n# = case (if null (range ixs)
 239                   then 0
 240                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 241     in
 242     case (newCharArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 243     (_MutableByteArray ixs barr#, S# s2#)}
 244
 245 newIntArray ixs@(ix_start, ix_end) (S# s#)
 246   = let n# = case (if null (range ixs)
 247                   then 0
 248                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 249     in
 250     case (newIntArray# n# s#)     of { StateAndMutableByteArray# s2# barr# ->
 251     (_MutableByteArray ixs barr#, S# s2#)}
 252
 253 newAddrArray ixs@(ix_start, ix_end) (S# s#)
 254   = let n# = case (if null (range ixs)
 255                   then 0
 256                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 257     in
 258     case (newAddrArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 259     (_MutableByteArray ixs barr#, S# s2#)}
 260
 261 newFloatArray ixs@(ix_start, ix_end) (S# s#)
 262   = let n# = case (if null (range ixs)
 263                   then 0
 264                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 265     in
 266     case (newFloatArray# n# s#)   of { StateAndMutableByteArray# s2# barr# ->
 267     (_MutableByteArray ixs barr#, S# s2#)}
 268
 269 newDoubleArray ixs@(ix_start, ix_end) (S# s#)
 270   = let n# = case (if null (range ixs)
 271                   then 0
 272                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 273     in
 274 --    trace ("newDoubleArray:"++(show (I# n#))) (
 275     case (newDoubleArray# n# s#)  of { StateAndMutableByteArray# s2# barr# ->
 276     (_MutableByteArray ixs barr#, S# s2#)}
 277 --    )
 278 \end{code}
 279
 280 \begin{code}
 281 boundsOfArray     :: Ix ix => _MutableArray s ix elt -> (ix, ix)
 282 boundsOfByteArray :: Ix ix => _MutableByteArray s ix -> (ix, ix)
 283
 284 {-# SPECIALIZE boundsOfArray     :: _MutableArray s Int elt -> IPr #-}
 285 {-# SPECIALIZE boundsOfByteArray :: _MutableByteArray s Int -> IPr #-}
 286
 287 boundsOfArray     (_MutableArray     ixs _) = ixs
 288 boundsOfByteArray (_MutableByteArray ixs _) = ixs
 289 \end{code}
 290
 291 \begin{code}
 292 readArray       :: Ix ix => _MutableArray s ix elt -> ix -> _ST s elt
 293
 294 readCharArray   :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Char
 295 readIntArray    :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Int
 296 readAddrArray   :: Ix ix => _MutableByteArray s ix -> ix -> _ST s _Addr
 297 readFloatArray  :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Float
 298 readDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Double
 299
 300 {-# SPECIALIZE readArray       :: _MutableArray s Int elt -> Int -> _ST s elt,
 301                                   _MutableArray s IPr elt -> IPr -> _ST s elt
 302   #-}
 303 {-# SPECIALIZE readCharArray   :: _MutableByteArray s Int -> Int -> _ST s Char #-}
 304 {-# SPECIALIZE readIntArray    :: _MutableByteArray s Int -> Int -> _ST s Int #-}
 305 {-# SPECIALIZE readAddrArray   :: _MutableByteArray s Int -> Int -> _ST s _Addr #-}
 306 --NO:{-# SPECIALIZE readFloatArray  :: _MutableByteArray s Int -> Int -> _ST s Float #-}
 307 {-# SPECIALIZE readDoubleArray :: _MutableByteArray s Int -> Int -> _ST s Double #-}
 308
 309 readArray (_MutableArray ixs arr#) n (S# s#)
 310   = case (index ixs n)          of { I# n# ->
 311     case readArray# arr# n# s#  of { StateAndPtr# s2# r ->
 312     (r, S# s2#)}}
 313
 314 readCharArray (_MutableByteArray ixs barr#) n (S# s#)
 315   = case (index ixs n)                  of { I# n# ->
 316     case readCharArray# barr# n# s#     of { StateAndChar# s2# r# ->
 317     (C# r#, S# s2#)}}
 318
 319 readIntArray (_MutableByteArray ixs barr#) n (S# s#)
 320   = case (index ixs n)                  of { I# n# ->
 321     case readIntArray# barr# n# s#      of { StateAndInt# s2# r# ->
 322     (I# r#, S# s2#)}}
 323
 324 readAddrArray (_MutableByteArray ixs barr#) n (S# s#)
 325   = case (index ixs n)                  of { I# n# ->
 326     case readAddrArray# barr# n# s#     of { StateAndAddr# s2# r# ->
 327     (A# r#, S# s2#)}}
 328
 329 readFloatArray (_MutableByteArray ixs barr#) n (S# s#)
 330   = case (index ixs n)                  of { I# n# ->
 331     case readFloatArray# barr# n# s#    of { StateAndFloat# s2# r# ->
 332     (F# r#, S# s2#)}}
 333
 334 readDoubleArray (_MutableByteArray ixs barr#) n (S# s#)
 335   = case (index ixs n)                  of { I# n# ->
 336 --    trace ("readDoubleArray:"++(show (I# n#))) (
 337     case readDoubleArray# barr# n# s#   of { StateAndDouble# s2# r# ->
 338     (D# r#, S# s2#)}}
 339 \end{code}
 340
 341 Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
 342 \begin{code}
 343 indexCharArray   :: Ix ix => _ByteArray ix -> ix -> Char
 344 indexIntArray    :: Ix ix => _ByteArray ix -> ix -> Int
 345 indexAddrArray   :: Ix ix => _ByteArray ix -> ix -> _Addr
 346 indexFloatArray  :: Ix ix => _ByteArray ix -> ix -> Float
 347 indexDoubleArray :: Ix ix => _ByteArray ix -> ix -> Double
 348
 349 {-# SPECIALIZE indexCharArray   :: _ByteArray Int -> Int -> Char #-}
 350 {-# SPECIALIZE indexIntArray    :: _ByteArray Int -> Int -> Int #-}
 351 {-# SPECIALIZE indexAddrArray   :: _ByteArray Int -> Int -> _Addr #-}
 352 --NO:{-# SPECIALIZE indexFloatArray  :: _ByteArray Int -> Int -> Float #-}
 353 {-# SPECIALIZE indexDoubleArray :: _ByteArray Int -> Int -> Double #-}
 354
 355 indexCharArray (_ByteArray ixs barr#) n
 356   = case (index ixs n)                  of { I# n# ->
 357     case indexCharArray# barr# n#       of { r# ->
 358     (C# r#)}}
 359
 360 indexIntArray (_ByteArray ixs barr#) n
 361   = case (index ixs n)                  of { I# n# ->
 362     case indexIntArray# barr# n#        of { r# ->
 363     (I# r#)}}
 364
 365 indexAddrArray (_ByteArray ixs barr#) n
 366   = case (index ixs n)                  of { I# n# ->
 367     case indexAddrArray# barr# n#       of { r# ->
 368     (A# r#)}}
 369
 370 indexFloatArray (_ByteArray ixs barr#) n
 371   = case (index ixs n)                  of { I# n# ->
 372     case indexFloatArray# barr# n#      of { r# ->
 373     (F# r#)}}
 374
 375 indexDoubleArray (_ByteArray ixs barr#) n
 376   = case (index ixs n)                  of { I# n# ->
 377 --    trace ("indexDoubleArray:"++(show (I# n#))) (
 378     case indexDoubleArray# barr# n#     of { r# ->
 379     (D# r#)}}
 380 \end{code}
 381
 382 Indexing off @_Addrs@ is similar, and therefore given here.
 383 \begin{code}
 384 indexCharOffAddr   :: _Addr -> Int -> Char
 385 indexIntOffAddr    :: _Addr -> Int -> Int
 386 indexAddrOffAddr   :: _Addr -> Int -> _Addr
 387 indexFloatOffAddr  :: _Addr -> Int -> Float
 388 indexDoubleOffAddr :: _Addr -> Int -> Double
 389
 390 indexCharOffAddr (A# addr#) n
 391   = case n                              of { I# n# ->
 392     case indexCharOffAddr# addr# n#     of { r# ->
 393     (C# r#)}}
 394
 395 indexIntOffAddr (A# addr#) n
 396   = case n                              of { I# n# ->
 397     case indexIntOffAddr# addr# n#      of { r# ->
 398     (I# r#)}}
 399
 400 indexAddrOffAddr (A# addr#) n
 401   = case n                              of { I# n# ->
 402     case indexAddrOffAddr# addr# n#     of { r# ->
 403     (A# r#)}}
 404
 405 indexFloatOffAddr (A# addr#) n
 406   = case n                              of { I# n# ->
 407     case indexFloatOffAddr# addr# n#    of { r# ->
 408     (F# r#)}}
 409
 410 indexDoubleOffAddr (A# addr#) n
 411   = case n                              of { I# n# ->
 412     case indexDoubleOffAddr# addr# n#   of { r# ->
 413     (D# r#)}}
 414 \end{code}
 415
 416 \begin{code}
 417 writeArray       :: Ix ix => _MutableArray s ix elt -> ix -> elt -> _ST s ()
 418 writeCharArray   :: Ix ix => _MutableByteArray s ix -> ix -> Char -> _ST s ()
 419 writeIntArray    :: Ix ix => _MutableByteArray s ix -> ix -> Int  -> _ST s ()
 420 writeAddrArray   :: Ix ix => _MutableByteArray s ix -> ix -> _Addr -> _ST s ()
 421 writeFloatArray  :: Ix ix => _MutableByteArray s ix -> ix -> Float -> _ST s ()
 422 writeDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> Double -> _ST s ()
 423
 424 {-# SPECIALIZE writeArray       :: _MutableArray s Int elt -> Int -> elt -> _ST s (),
 425                                    _MutableArray s IPr elt -> IPr -> elt -> _ST s ()
 426   #-}
 427 {-# SPECIALIZE writeCharArray   :: _MutableByteArray s Int -> Int -> Char -> _ST s () #-}
 428 {-# SPECIALIZE writeIntArray    :: _MutableByteArray s Int -> Int -> Int  -> _ST s () #-}
 429 {-# SPECIALIZE writeAddrArray   :: _MutableByteArray s Int -> Int -> _Addr -> _ST s () #-}
 430 --NO:{-# SPECIALIZE writeFloatArray  :: _MutableByteArray s Int -> Int -> Float -> _ST s () #-}
 431 {-# SPECIALIZE writeDoubleArray :: _MutableByteArray s Int -> Int -> Double -> _ST s () #-}
 432
 433 writeArray (_MutableArray ixs arr#) n ele (S# s#)
 434   = case index ixs n                of { I# n# ->
 435     case writeArray# arr# n# ele s# of { s2# ->
 436     ((), S# s2#)}}
 437
 438 writeCharArray (_MutableByteArray ixs barr#) n (C# ele) (S# s#)
 439   = case (index ixs n)                      of { I# n# ->
 440     case writeCharArray# barr# n# ele s#    of { s2#   ->
 441     ((), S# s2#)}}
 442
 443 writeIntArray (_MutableByteArray ixs barr#) n (I# ele) (S# s#)
 444   = case (index ixs n)                      of { I# n# ->
 445     case writeIntArray# barr# n# ele s#     of { s2#   ->
 446     ((), S# s2#)}}
 447
 448 writeAddrArray (_MutableByteArray ixs barr#) n (A# ele) (S# s#)
 449   = case (index ixs n)                      of { I# n# ->
 450     case writeAddrArray# barr# n# ele s#    of { s2#   ->
 451     ((), S# s2#)}}
 452
 453 writeFloatArray (_MutableByteArray ixs barr#) n (F# ele) (S# s#)
 454   = case (index ixs n)                      of { I# n# ->
 455     case writeFloatArray# barr# n# ele s#   of { s2#   ->
 456     ((), S# s2#)}}
 457
 458 writeDoubleArray (_MutableByteArray ixs barr#) n (D# ele) (S# s#)
 459   = case (index ixs n)                      of { I# n# ->
 460 --    trace ("writeDoubleArray:"++(show (I# n#))) (
 461     case writeDoubleArray# barr# n# ele s#  of { s2#   ->
 462     ((), S# s2#)}}
 463 \end{code}
 464
 465 \begin{code}
 466 freezeArray, _freezeArray :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
 467 freezeCharArray   :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 468 freezeIntArray    :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 469 freezeAddrArray   :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 470 freezeFloatArray  :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 471 freezeDoubleArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 472
 473 {-# SPECIALISE _freezeArray :: _MutableArray s Int elt -> _ST s (Array Int elt),
 474                                _MutableArray s IPr elt -> _ST s (Array IPr elt)
 475   #-}
 476 {-# SPECIALISE freezeCharArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int) #-}
 477
 478 freezeArray = _freezeArray
 479
 480 _freezeArray (_MutableArray ixs@(ix_start, ix_end) arr#) (S# s#)
 481   = let n# = case (if null (range ixs)
 482                   then 0
 483                   else (index ixs ix_end) + 1) of { I# x -> x }
 484     in
 485     case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
 486     (_Array ixs frozen#, S# s2#)}
 487   where
 488     freeze  :: MutableArray# s ele      -- the thing
 489             -> Int#                     -- size of thing to be frozen
 490             -> State# s                 -- the Universe and everything
 491             -> StateAndArray# s ele
 492
 493     freeze arr# n# s#
 494       = case newArray# n# init s#             of { StateAndMutableArray# s2# newarr1# ->
 495         case copy 0# n# arr# newarr1# s2#     of { StateAndMutableArray# s3# newarr2# ->
 496         unsafeFreezeArray# newarr2# s3#
 497         }}
 498       where
 499         init = error "freezeArr: element not copied"
 500
 501         copy :: Int# -> Int#
 502              -> MutableArray# s ele -> MutableArray# s ele
 503              -> State# s
 504              -> StateAndMutableArray# s ele
 505
 506         copy cur# end# from# to# s#
 507           | cur# ==# end#
 508             = StateAndMutableArray# s# to#
 509           | True
 510             = case readArray#  from# cur#     s#  of { StateAndPtr# s1# ele ->
 511               case writeArray# to#   cur# ele s1# of { s2# ->
 512               copy (cur# +# 1#) end# from# to# s2#
 513               }}
 514
 515 freezeCharArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 516   = let n# = case (if null (range ixs)
 517                   then 0
 518                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 519     in
 520     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 521     (_ByteArray ixs frozen#, S# s2#) }
 522   where
 523     freeze  :: MutableByteArray# s      -- the thing
 524             -> Int#                     -- size of thing to be frozen
 525             -> State# s                 -- the Universe and everything
 526             -> StateAndByteArray# s
 527
 528     freeze arr# n# s#
 529       = case (newCharArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 530         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 531         unsafeFreezeByteArray# newarr2# s3#
 532         }}
 533       where
 534         copy :: Int# -> Int#
 535              -> MutableByteArray# s -> MutableByteArray# s
 536              -> State# s
 537              -> StateAndMutableByteArray# s
 538
 539         copy cur# end# from# to# s#
 540           | cur# ==# end#
 541             = StateAndMutableByteArray# s# to#
 542           | True
 543             = case (readCharArray#  from# cur#     s#)  of { StateAndChar# s1# ele ->
 544               case (writeCharArray# to#   cur# ele s1#) of { s2# ->
 545               copy (cur# +# 1#) end# from# to# s2#
 546               }}
 547
 548 freezeIntArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 549   = let n# = case (if null (range ixs)
 550                   then 0
 551                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 552     in
 553     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 554     (_ByteArray ixs frozen#, S# s2#) }
 555   where
 556     freeze  :: MutableByteArray# s      -- the thing
 557             -> Int#                     -- size of thing to be frozen
 558             -> State# s                 -- the Universe and everything
 559             -> StateAndByteArray# s
 560
 561     freeze arr# n# s#
 562       = case (newIntArray# n# s#)          of { StateAndMutableByteArray# s2# newarr1# ->
 563         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 564         unsafeFreezeByteArray# newarr2# s3#
 565         }}
 566       where
 567         copy :: Int# -> Int#
 568              -> MutableByteArray# s -> MutableByteArray# s
 569              -> State# s
 570              -> StateAndMutableByteArray# s
 571
 572         copy cur# end# from# to# s#
 573           | cur# ==# end#
 574             = StateAndMutableByteArray# s# to#
 575           | True
 576             = case (readIntArray#  from# cur#     s#)  of { StateAndInt# s1# ele ->
 577               case (writeIntArray# to#   cur# ele s1#) of { s2# ->
 578               copy (cur# +# 1#) end# from# to# s2#
 579               }}
 580
 581 freezeAddrArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 582   = let n# = case (if null (range ixs)
 583                   then 0
 584                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 585     in
 586     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 587     (_ByteArray ixs frozen#, S# s2#) }
 588   where
 589     freeze  :: MutableByteArray# s      -- the thing
 590             -> Int#                     -- size of thing to be frozen
 591             -> State# s                 -- the Universe and everything
 592             -> StateAndByteArray# s
 593
 594     freeze arr# n# s#
 595       = case (newAddrArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 596         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 597         unsafeFreezeByteArray# newarr2# s3#
 598         }}
 599       where
 600         copy :: Int# -> Int#
 601              -> MutableByteArray# s -> MutableByteArray# s
 602              -> State# s
 603              -> StateAndMutableByteArray# s
 604
 605         copy cur# end# from# to# s#
 606           | cur# ==# end#
 607             = StateAndMutableByteArray# s# to#
 608           | True
 609             = case (readAddrArray#  from# cur#     s#)  of { StateAndAddr# s1# ele ->
 610               case (writeAddrArray# to#   cur# ele s1#) of { s2# ->
 611               copy (cur# +# 1#) end# from# to# s2#
 612               }}
 613
 614 freezeFloatArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 615   = let n# = case (if null (range ixs)
 616                   then 0
 617                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 618     in
 619     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 620     (_ByteArray ixs frozen#, S# s2#) }
 621   where
 622     freeze  :: MutableByteArray# s      -- the thing
 623             -> Int#                     -- size of thing to be frozen
 624             -> State# s                 -- the Universe and everything
 625             -> StateAndByteArray# s
 626
 627     freeze arr# n# s#
 628       = case (newFloatArray# n# s#)        of { StateAndMutableByteArray# s2# newarr1# ->
 629         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 630         unsafeFreezeByteArray# newarr2# s3#
 631         }}
 632       where
 633         copy :: Int# -> Int#
 634              -> MutableByteArray# s -> MutableByteArray# s
 635              -> State# s
 636              -> StateAndMutableByteArray# s
 637
 638         copy cur# end# from# to# s#
 639           | cur# ==# end#
 640             = StateAndMutableByteArray# s# to#
 641           | True
 642             = case (readFloatArray#  from# cur#     s#)  of { StateAndFloat# s1# ele ->
 643               case (writeFloatArray# to#   cur# ele s1#) of { s2# ->
 644               copy (cur# +# 1#) end# from# to# s2#
 645               }}
 646
 647 freezeDoubleArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
 648   = let n# = case (if null (range ixs)
 649                   then 0
 650                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 651     in
 652     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 653     (_ByteArray ixs frozen#, S# s2#) }
 654   where
 655     freeze  :: MutableByteArray# s      -- the thing
 656             -> Int#                     -- size of thing to be frozen
 657             -> State# s                 -- the Universe and everything
 658             -> StateAndByteArray# s
 659
 660     freeze arr# n# s#
 661       = case (newDoubleArray# n# s#)       of { StateAndMutableByteArray# s2# newarr1# ->
 662         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 663         unsafeFreezeByteArray# newarr2# s3#
 664         }}
 665       where
 666         copy :: Int# -> Int#
 667              -> MutableByteArray# s -> MutableByteArray# s
 668              -> State# s
 669              -> StateAndMutableByteArray# s
 670
 671         copy cur# end# from# to# s#
 672           | cur# ==# end#
 673             = StateAndMutableByteArray# s# to#
 674           | True
 675             = case (readDoubleArray#  from# cur#     s#)  of { StateAndDouble# s1# ele ->
 676               case (writeDoubleArray# to#   cur# ele s1#) of { s2# ->
 677               copy (cur# +# 1#) end# from# to# s2#
 678               }}
 679 \end{code}
 680
 681 \begin{code}
 682 unsafeFreezeArray     :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
 683 unsafeFreezeByteArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
 684
 685 {-# SPECIALIZE unsafeFreezeByteArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
 686   #-}
 687
 688 unsafeFreezeArray (_MutableArray ixs arr#) (S# s#)
 689   = case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
 690     (_Array ixs frozen#, S# s2#) }
 691
 692 unsafeFreezeByteArray (_MutableByteArray ixs arr#) (S# s#)
 693   = case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 694     (_ByteArray ixs frozen#, S# s2#) }
 695 \end{code}
 696
 697 This takes a immutable array, and copies it into a mutable array, in a
 698 hurry.
 699
 700 \begin{code}
 701 {-# SPECIALISE thawArray :: Array Int elt -> _ST s (_MutableArray s Int elt),
 702                             Array IPr elt -> _ST s (_MutableArray s IPr elt)
 703   #-}
 704
 705 thawArray (_Array ixs@(ix_start, ix_end) arr#) (S# s#)
 706   = let n# = case (if null (range ixs)
 707                   then 0
 708                   else (index ixs ix_end) + 1) of { I# x -> x }
 709     in
 710     case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
 711     (_MutableArray ixs thawed#, S# s2#)}
 712   where
 713     thaw  :: Array# ele                 -- the thing
 714             -> Int#                     -- size of thing to be thawed
 715             -> State# s                 -- the Universe and everything
 716             -> StateAndMutableArray# s ele
 717
 718     thaw arr# n# s#
 719       = case newArray# n# init s#             of { StateAndMutableArray# s2# newarr1# ->
 720         copy 0# n# arr# newarr1# s2# }
 721       where
 722         init = error "thawArr: element not copied"
 723
 724         copy :: Int# -> Int#
 725              -> Array# ele
 726              -> MutableArray# s ele
 727              -> State# s
 728              -> StateAndMutableArray# s ele
 729
 730         copy cur# end# from# to# s#
 731           | cur# ==# end#
 732             = StateAndMutableArray# s# to#
 733           | True
 734             = case indexArray#  from# cur#       of { _Lift ele ->
 735               case writeArray# to#   cur# ele s# of { s1# ->
 736               copy (cur# +# 1#) end# from# to# s1#
 737               }}
 738 \end{code}
 739
 740 \begin{code}
 741 sameMutableArray     :: _MutableArray s ix elt -> _MutableArray s ix elt -> Bool
 742 sameMutableByteArray :: _MutableByteArray s ix -> _MutableByteArray s ix -> Bool
 743
 744 sameMutableArray (_MutableArray _ arr1#) (_MutableArray _ arr2#)
 745   = sameMutableArray# arr1# arr2#
 746
 747 sameMutableByteArray (_MutableByteArray _ arr1#) (_MutableByteArray _ arr2#)
 748   = sameMutableByteArray# arr1# arr2#
 749 \end{code}
 750
 751 %************************************************************************
 752 %*                                                                      *
 753 \subsection[PreludeGlaST-variables]{Variables}
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 \begin{code}
 758 type MutableVar s a = _MutableArray s Int a
 759 \end{code}
 760
 761 \begin{code}
 762 newVar   :: a -> _ST s (MutableVar s a)
 763 readVar  :: MutableVar s a -> _ST s a
 764 writeVar :: MutableVar s a -> a -> _ST s ()
 765 sameVar  :: MutableVar s a -> MutableVar s a -> Bool
 766
 767 {- MUCH GRATUITOUS INEFFICIENCY: WDP 95/09:
 768
 769 newVar init    s = newArray (0,0) init s
 770 readVar v      s = readArray v 0 s
 771 writeVar v val s = writeArray v 0 val s
 772 sameVar v1 v2    = sameMutableArray v1 v2
 773 -}
 774
 775 newVar init (S# s#)
 776   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 777     (_MutableArray vAR_IXS arr#, S# s2#) }
 778   where
 779     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 780
 781 readVar (_MutableArray _ var#) (S# s#)
 782   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 783     (r, S# s2#) }
 784
 785 writeVar (_MutableArray _ var#) val (S# s#)
 786   = case writeArray# var# 0# val s# of { s2# ->
 787     ((), S# s2#) }
 788
 789 sameVar (_MutableArray _ var1#) (_MutableArray _ var2#)
 790   = sameMutableArray# var1# var2#
 791 \end{code}