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