ghc/lib/prelude/GHCbase.hs

   1 {- The GHCbase module includes all the basic
   2    (next-level-above-primitives) GHC-specific code;
   3    used to define Prelude.hs, and also other "packagings"
   4    of Glasgow extensions.
   5
   6    Users should not import it directly.
   7 -}
   8 module GHCbase where
   9
  10 import Array            ( array, bounds, assocs )
  11 import Char             (isDigit,isUpper,isSpace,isAlphanum,isAlpha,isOctDigit,isHexDigit)
  12 import Ix
  13 import Ratio
  14 import qualified GHCps  ( packString, packCBytes, comparePS, unpackPS )
  15 import qualified GHCio  ( IOError )
  16 import qualified Monad
  17
  18 infixr 0 `seq`, `par`, `fork`
  19
  20 {- =============================================================
  21 There's a lot in GHCbase.  It's set out as follows:
  22
  23 * Classes (CCallable, CReturnable, ...)
  24
  25 * Types and their instances
  26
  27 * ST, PrimIO, and IO monads
  28
  29 * Basic arrays
  30
  31 * Variables
  32
  33 * Thread waiting
  34
  35 * Other support functions
  36
  37 ============================================================= -}
  38
  39 {- =============================================================
  40 ** CLASSES
  41 -}
  42
  43 class CCallable   a
  44 class CReturnable a
  45
  46 {- =============================================================
  47 ** TYPES and their instances
  48 -}
  49 data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension
  50 instance CCallable Addr
  51 instance CReturnable Addr
  52
  53 ---------------------------------------------------------------
  54 data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension
  55 instance CCallable Word
  56 instance CReturnable Word
  57
  58 ---------------------------------------------------------------
  59 data PackedString
  60   = PS  ByteArray#  -- the bytes
  61         Int#        -- length (*not* including NUL at the end)
  62         Bool        -- True <=> contains a NUL
  63   | CPS Addr#       -- pointer to the (null-terminated) bytes in C land
  64         Int#        -- length, as per strlen
  65                     -- definitely doesn't contain a NUL
  66
  67 instance Eq PackedString where
  68     x == y  = compare x y == EQ
  69     x /= y  = compare x y /= EQ
  70
  71 instance Ord PackedString where
  72     compare = GHCps.comparePS
  73     x <= y  = compare x y /= GT
  74     x <  y  = compare x y == LT
  75     x >= y  = compare x y /= LT
  76     x >  y  = compare x y == GT
  77     max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
  78     min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
  79
  80 --instance Read PackedString: ToDo
  81
  82 instance Show PackedString where
  83     showsPrec p ps r = showsPrec p (GHCps.unpackPS ps) r
  84     showList = showList__ (showsPrec 0)
  85
  86 ---------------------------------------------------------------
  87 data State a = S# (State# a)
  88 data ForeignObj = ForeignObj ForeignObj#
  89 #ifndef __PARALLEL_HASKELL__
  90 data StablePtr a = StablePtr (StablePtr# a)
  91 #endif
  92
  93 instance CCallable   (StablePtr a)
  94 instance CCallable   ForeignObj
  95 instance CReturnable (StablePtr a)
  96
  97 #ifndef __PARALLEL_HASKELL__
  98
  99 -- Nota Bene: it is important {\em not\/} to inline calls to
 100 -- @makeStablePtr#@ since the corresponding macro is very long and we'll
 101 -- get terrible code-bloat.
 102
 103 makeStablePtr  :: a -> PrimIO (StablePtr a)
 104 deRefStablePtr :: StablePtr a -> PrimIO a
 105 freeStablePtr  :: StablePtr a -> PrimIO ()
 106
 107 eqForeignObj   :: ForeignObj -> ForeignObj -> Bool
 108 makeForeignObj :: Addr       -> Addr       -> PrimIO ForeignObj
 109 performGC      :: PrimIO ()
 110
 111 {-# INLINE deRefStablePtr #-}
 112 {-# INLINE freeStablePtr #-}
 113 {-# INLINE performGC #-}
 114
 115 makeStablePtr f = ST $ \ (S# rw1#) ->
 116     case makeStablePtr# f rw1# of
 117       StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#)
 118
 119 deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) ->
 120     case deRefStablePtr# sp# rw1# of
 121       StateAndPtr# rw2# a -> (a, S# rw2#)
 122
 123 freeStablePtr sp = _ccall_ freeStablePointer sp
 124
 125 makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) ->
 126     case makeForeignObj# obj finaliser s# of
 127       StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#)
 128
 129 eqForeignObj mp1 mp2
 130   = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
 131
 132 instance Eq ForeignObj where
 133     p == q = eqForeignObj p q
 134     p /= q = not (eqForeignObj p q)
 135
 136 performGC = _ccall_GC_ StgPerformGarbageCollection
 137
 138 #endif /* !__PARALLEL_HASKELL__ */
 139
 140 ---------------------------------------------------------------
 141 data Return2GMPs     = Return2GMPs     Int# Int# ByteArray# Int# Int# ByteArray#
 142 data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
 143
 144 data StateAndPtr#    s elt = StateAndPtr#    (State# s) elt
 145
 146 data StateAndChar#   s     = StateAndChar#   (State# s) Char#
 147 data StateAndInt#    s     = StateAndInt#    (State# s) Int#
 148 data StateAndWord#   s     = StateAndWord#   (State# s) Word#
 149 data StateAndFloat#  s     = StateAndFloat#  (State# s) Float#
 150 data StateAndDouble# s     = StateAndDouble# (State# s) Double#
 151 data StateAndAddr#   s     = StateAndAddr#   (State# s) Addr#
 152
 153 #ifndef __PARALLEL_HASKELL__
 154 data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
 155 #endif
 156 data StateAndForeignObj# s  = StateAndForeignObj# (State# s) ForeignObj#
 157
 158 data StateAndArray#            s elt = StateAndArray#        (State# s) (Array# elt)
 159 data StateAndMutableArray#     s elt = StateAndMutableArray# (State# s) (MutableArray# s elt)
 160 data StateAndByteArray#        s = StateAndByteArray#        (State# s) ByteArray#
 161 data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s)
 162
 163 data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
 164
 165 ---------------------------------------------------------------
 166 data Lift a = Lift a
 167 {-# GENERATE_SPECS data a :: Lift a #-}
 168
 169 {- =============================================================
 170 ** ST, PrimIO, and IO monads
 171 -}
 172
 173 ---------------------------------------------------------------
 174 --The state-transformer proper
 175 -- By default the monad is strict; too many people got bitten by
 176 -- space leaks when it was lazy.
 177
 178 newtype ST s a = ST (State s -> (a, State s))
 179
 180 runST (ST m)
 181   = case m (S# realWorld#) of
 182       (r,_) -> r
 183
 184 instance Monad (ST s) where
 185     {-# INLINE return #-}
 186     {-# INLINE (>>)   #-}
 187     {-# INLINE (>>=)  #-}
 188     return x = ST $ \ s -> (x, s)
 189     m >> k   =  m >>= \ _ -> k
 190
 191     (ST m) >>= k
 192       = ST $ \ s ->
 193         case (m s) of {(r, new_s) ->
 194         case (k r) of { ST k2 ->
 195         (k2 new_s) }}
 196
 197 {-# INLINE returnST #-}
 198
 199 -- here for backward compatibility:
 200 returnST :: a -> ST s a
 201 thenST   :: ST s a -> (a -> ST s b) -> ST s b
 202 seqST    :: ST s a -> ST s b -> ST s b
 203
 204 returnST = return
 205 thenST   = (>>=)
 206 seqST    = (>>)
 207
 208 -- not sure whether to 1.3-ize these or what...
 209 {-# INLINE returnStrictlyST #-}
 210 {-# INLINE thenStrictlyST #-}
 211 {-# INLINE seqStrictlyST #-}
 212
 213 {-# GENERATE_SPECS returnStrictlyST a #-}
 214 returnStrictlyST :: a -> ST s a
 215
 216 {-# GENERATE_SPECS thenStrictlyST a b #-}
 217 thenStrictlyST :: ST s a -> (a -> ST s b) -> ST s b
 218
 219 {-# GENERATE_SPECS seqStrictlyST a b #-}
 220 seqStrictlyST :: ST s a -> ST s b -> ST s b
 221
 222 returnStrictlyST a = ST $ \ s@(S# _) -> (a, s)
 223
 224 thenStrictlyST (ST m) k = ST $ \ s ->   -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
 225     case (m s) of { (r, new_s) ->
 226     case (k r) of { ST k2     ->
 227     (k2 new_s) }}
 228
 229 seqStrictlyST (ST m) (ST k) = ST $ \ s ->       -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
 230     case (m s) of { (_, new_s) ->
 231     (k new_s) }
 232
 233 -- BUILT-IN: runST (see Builtin.hs)
 234
 235 unsafeInterleaveST :: ST s a -> ST s a    -- ToDo: put in state-interface.tex
 236 unsafeInterleaveST (ST m) = ST $ \ s ->
 237     let
 238         (r, new_s) = m s
 239     in
 240     (r, s)
 241
 242 fixST :: (a -> ST s a) -> ST s a
 243 fixST k = ST $ \ s ->
 244     let (ST k_r)  = k r
 245         ans       = k_r s
 246         (r,new_s) = ans
 247     in
 248     ans
 249
 250 -- more backward compatibility stuff:
 251 listST          :: [ST s a] -> ST s [a]
 252 mapST           :: (a -> ST s b) -> [a] -> ST s [b]
 253 mapAndUnzipST   :: (a -> ST s (b,c)) -> [a] -> ST s ([b],[c])
 254
 255 listST          = accumulate
 256 mapST           = mapM
 257 mapAndUnzipST   = Monad.mapAndUnzipL
 258
 259 forkST :: ST s a -> ST s a
 260
 261 #ifndef __CONCURRENT_HASKELL__
 262 forkST x = x
 263 #else
 264
 265 forkST (ST action) = ST $ \ s ->
 266    let
 267     (r, new_s) = action s
 268    in
 269     new_s `_fork_` (r, s)
 270  where
 271     _fork_ x y = case (fork# x) of { 0# -> parError#; _ -> y }
 272
 273 #endif {- concurrent -}
 274
 275 ----------------------------------------------------------------------------
 276 type PrimIO a = ST RealWorld a
 277
 278 fixPrimIO :: (a -> PrimIO a) -> PrimIO a
 279 fixPrimIO = fixST
 280
 281 stToIO     :: ST RealWorld a -> IO a
 282 primIOToIO :: PrimIO a       -> IO a
 283 ioToST     :: IO a -> ST RealWorld a
 284 ioToPrimIO :: IO a -> PrimIO       a
 285
 286 primIOToIO = stToIO -- for backwards compatibility
 287 ioToPrimIO = ioToST
 288
 289 stToIO (ST m) = IO $ ST $ \ s ->
 290     case (m s) of { (r, new_s) ->
 291     (Right r, new_s) }
 292
 293 ioToST (IO (ST io)) = ST $ \ s ->
 294     case (io s) of { (r, new_s) ->
 295     case r of
 296       Right a -> (a, new_s)
 297       Left  e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
 298     }
 299
 300 {-# GENERATE_SPECS unsafePerformPrimIO a #-}
 301 unsafePerformPrimIO     :: PrimIO a -> a
 302 unsafeInterleavePrimIO  :: PrimIO a -> PrimIO a
 303 forkPrimIO              :: PrimIO a -> PrimIO a
 304
 305 unsafePerformPrimIO     = runST
 306 unsafeInterleavePrimIO  = unsafeInterleaveST
 307 forkPrimIO              = forkST
 308
 309 -- the following functions are now there for backward compatibility mostly:
 310
 311 {-# GENERATE_SPECS returnPrimIO a #-}
 312 returnPrimIO    :: a -> PrimIO a
 313
 314 {-# GENERATE_SPECS thenPrimIO b #-}
 315 thenPrimIO      :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
 316
 317 {-# GENERATE_SPECS seqPrimIO b #-}
 318 seqPrimIO       :: PrimIO a -> PrimIO b -> PrimIO b
 319
 320 listPrimIO      :: [PrimIO a] -> PrimIO [a]
 321 mapPrimIO       :: (a -> PrimIO b) -> [a] -> PrimIO [b]
 322 mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c])
 323
 324 {-# INLINE returnPrimIO #-}
 325 {-# INLINE thenPrimIO   #-}
 326 {-# INLINE seqPrimIO  #-}
 327
 328 returnPrimIO      = return
 329 thenPrimIO        = (>>=)
 330 seqPrimIO         = (>>)
 331 listPrimIO        = accumulate
 332 mapPrimIO         = mapM
 333 mapAndUnzipPrimIO = Monad.mapAndUnzipL
 334
 335 ---------------------------------------------------------
 336 newtype IO a = IO (PrimIO (Either GHCio.IOError a))
 337
 338 instance  Functor IO where
 339    map f x = x >>= (return . f)
 340
 341 instance  Monad IO  where
 342     {-# INLINE return #-}
 343     {-# INLINE (>>)   #-}
 344     {-# INLINE (>>=)  #-}
 345     m >> k      =  m >>= \ _ -> k
 346     return x    = IO $ ST $ \ s@(S# _) -> (Right x, s)
 347
 348     (IO (ST m)) >>= k
 349       = IO $ ST $ \ s ->
 350         let  (r, new_s) = m s  in
 351         case r of
 352           Left err -> (Left err, new_s)
 353           Right  x -> case (k x) of { IO (ST k2) ->
 354                       k2 new_s }
 355
 356 instance  Show (IO a)  where
 357     showsPrec p f  = showString "<<IO action>>"
 358     showList       = showList__ (showsPrec 0)
 359
 360 fixIO :: (a -> IO a) -> IO a
 361     -- not required but worth having around
 362
 363 fixIO k = IO $ ST $ \ s ->
 364     let
 365         (IO (ST k_loop)) = k loop
 366         result           = k_loop s
 367         (Right loop, _)  = result
 368     in
 369     result
 370
 371 {- =============================================================
 372 ** BASIC ARRAY (and ByteArray) SUPPORT
 373 -}
 374
 375 type IPr = (Int, Int)
 376
 377 data Ix ix => Array      ix elt = Array     (ix,ix) (Array# elt)
 378 data Ix ix => ByteArray ix      = ByteArray (ix,ix) ByteArray#
 379
 380 instance CCallable (ByteArray ix)
 381
 382 instance  (Ix a, Eq b)  => Eq (Array a b)  where
 383     a == a'             =  assocs a == assocs a'
 384     a /= a'             =  assocs a /= assocs a'
 385
 386 instance  (Ix a, Ord b) => Ord (Array a b)  where
 387     compare a b = compare (assocs a) (assocs b)
 388
 389 instance  (Ix a, Show a, Show b) => Show (Array a b)  where
 390     showsPrec p a = showParen (p > 9) (
 391                     showString "array " .
 392                     shows (bounds a) . showChar ' ' .
 393                     shows (assocs a)                  )
 394     showList = showList__ (showsPrec 0)
 395
 396 instance  (Ix a, Read a, Read b) => Read (Array a b)  where
 397     readsPrec p = readParen (p > 9)
 398            (\r -> [(array b as, u) | ("array",s) <- lex r,
 399                                      (b,t)       <- reads s,
 400                                      (as,u)      <- reads t   ])
 401     readList = readList__ (readsPrec 0)
 402
 403 -----------------------------------------------------------------
 404 -- Mutable arrays
 405 {-
 406 Idle ADR question: What's the tradeoff here between flattening these
 407 datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using
 408 it as is?  As I see it, the former uses slightly less heap and
 409 provides faster access to the individual parts of the bounds while the
 410 code used has the benefit of providing a ready-made @(lo, hi)@ pair as
 411 required by many array-related functions.  Which wins? Is the
 412 difference significant (probably not).
 413
 414 Idle AJG answer: When I looked at the outputted code (though it was 2
 415 years ago) it seems like you often needed the tuple, and we build
 416 it frequently. Now we've got the overloading specialiser things
 417 might be different, though.
 418 -}
 419
 420 data Ix ix => MutableArray     s ix elt = MutableArray     (ix,ix) (MutableArray# s elt)
 421 data Ix ix => MutableByteArray s ix     = MutableByteArray (ix,ix) (MutableByteArray# s)
 422
 423 instance CCallable (MutableByteArray s ix)
 424
 425 newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt)
 426 newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray
 427          :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
 428
 429 {-# SPECIALIZE newArray      :: IPr       -> elt -> ST s (MutableArray s Int elt),
 430                                 (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt)
 431   #-}
 432 {-# SPECIALIZE newCharArray   :: IPr -> ST s (MutableByteArray s Int) #-}
 433 {-# SPECIALIZE newIntArray    :: IPr -> ST s (MutableByteArray s Int) #-}
 434 {-# SPECIALIZE newAddrArray   :: IPr -> ST s (MutableByteArray s Int) #-}
 435 {-# SPECIALIZE newFloatArray  :: IPr -> ST s (MutableByteArray s Int) #-}
 436 {-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
 437
 438 newArray ixs@(ix_start, ix_end) init = ST $ \ (S# s#) ->
 439     let n# = case (if null (range ixs)
 440                   then 0
 441                   else (index ixs ix_end) + 1) of { I# x -> x }
 442         -- size is one bigger than index of last elem
 443     in
 444     case (newArray# n# init s#)     of { StateAndMutableArray# s2# arr# ->
 445     (MutableArray ixs arr#, S# s2#)}
 446
 447 newCharArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
 448     let n# = case (if null (range ixs)
 449                   then 0
 450                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 451     in
 452     case (newCharArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 453     (MutableByteArray ixs barr#, S# s2#)}
 454
 455 newIntArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
 456     let n# = case (if null (range ixs)
 457                   then 0
 458                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 459     in
 460     case (newIntArray# n# s#)     of { StateAndMutableByteArray# s2# barr# ->
 461     (MutableByteArray ixs barr#, S# s2#)}
 462
 463 newAddrArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
 464     let n# = case (if null (range ixs)
 465                   then 0
 466                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 467     in
 468     case (newAddrArray# n# s#)    of { StateAndMutableByteArray# s2# barr# ->
 469     (MutableByteArray ixs barr#, S# s2#)}
 470
 471 newFloatArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
 472     let n# = case (if null (range ixs)
 473                   then 0
 474                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 475     in
 476     case (newFloatArray# n# s#)   of { StateAndMutableByteArray# s2# barr# ->
 477     (MutableByteArray ixs barr#, S# s2#)}
 478
 479 newDoubleArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
 480     let n# = case (if null (range ixs)
 481                   then 0
 482                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 483     in
 484     case (newDoubleArray# n# s#)  of { StateAndMutableByteArray# s2# barr# ->
 485     (MutableByteArray ixs barr#, S# s2#)}
 486
 487 boundsOfArray     :: Ix ix => MutableArray s ix elt -> (ix, ix)
 488 boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
 489
 490 {-# SPECIALIZE boundsOfArray     :: MutableArray s Int elt -> IPr #-}
 491 {-# SPECIALIZE boundsOfByteArray :: MutableByteArray s Int -> IPr #-}
 492
 493 boundsOfArray     (MutableArray     ixs _) = ixs
 494 boundsOfByteArray (MutableByteArray ixs _) = ixs
 495
 496 readArray       :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
 497
 498 readCharArray   :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
 499 readIntArray    :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
 500 readAddrArray   :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
 501 readFloatArray  :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
 502 readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
 503
 504 {-# SPECIALIZE readArray       :: MutableArray s Int elt -> Int -> ST s elt,
 505                                   MutableArray s IPr elt -> IPr -> ST s elt
 506   #-}
 507 {-# SPECIALIZE readCharArray   :: MutableByteArray s Int -> Int -> ST s Char #-}
 508 {-# SPECIALIZE readIntArray    :: MutableByteArray s Int -> Int -> ST s Int #-}
 509 {-# SPECIALIZE readAddrArray   :: MutableByteArray s Int -> Int -> ST s Addr #-}
 510 --NO:{-# SPECIALIZE readFloatArray  :: MutableByteArray s Int -> Int -> ST s Float #-}
 511 {-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
 512
 513 readArray (MutableArray ixs arr#) n = ST $ \ (S# s#) ->
 514     case (index ixs n)          of { I# n# ->
 515     case readArray# arr# n# s#  of { StateAndPtr# s2# r ->
 516     (r, S# s2#)}}
 517
 518 readCharArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
 519     case (index ixs n)                  of { I# n# ->
 520     case readCharArray# barr# n# s#     of { StateAndChar# s2# r# ->
 521     (C# r#, S# s2#)}}
 522
 523 readIntArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
 524     case (index ixs n)                  of { I# n# ->
 525     case readIntArray# barr# n# s#      of { StateAndInt# s2# r# ->
 526     (I# r#, S# s2#)}}
 527
 528 readAddrArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
 529     case (index ixs n)                  of { I# n# ->
 530     case readAddrArray# barr# n# s#     of { StateAndAddr# s2# r# ->
 531     (A# r#, S# s2#)}}
 532
 533 readFloatArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
 534     case (index ixs n)                  of { I# n# ->
 535     case readFloatArray# barr# n# s#    of { StateAndFloat# s2# r# ->
 536     (F# r#, S# s2#)}}
 537
 538 readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
 539     case (index ixs n)                  of { I# n# ->
 540     case readDoubleArray# barr# n# s#   of { StateAndDouble# s2# r# ->
 541     (D# r#, S# s2#)}}
 542
 543 --Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
 544 indexCharArray   :: Ix ix => ByteArray ix -> ix -> Char
 545 indexIntArray    :: Ix ix => ByteArray ix -> ix -> Int
 546 indexAddrArray   :: Ix ix => ByteArray ix -> ix -> Addr
 547 indexFloatArray  :: Ix ix => ByteArray ix -> ix -> Float
 548 indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double
 549
 550 {-# SPECIALIZE indexCharArray   :: ByteArray Int -> Int -> Char #-}
 551 {-# SPECIALIZE indexIntArray    :: ByteArray Int -> Int -> Int #-}
 552 {-# SPECIALIZE indexAddrArray   :: ByteArray Int -> Int -> Addr #-}
 553 --NO:{-# SPECIALIZE indexFloatArray  :: ByteArray Int -> Int -> Float #-}
 554 {-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
 555
 556 indexCharArray (ByteArray ixs barr#) n
 557   = case (index ixs n)                  of { I# n# ->
 558     case indexCharArray# barr# n#       of { r# ->
 559     (C# r#)}}
 560
 561 indexIntArray (ByteArray ixs barr#) n
 562   = case (index ixs n)                  of { I# n# ->
 563     case indexIntArray# barr# n#        of { r# ->
 564     (I# r#)}}
 565
 566 indexAddrArray (ByteArray ixs barr#) n
 567   = case (index ixs n)                  of { I# n# ->
 568     case indexAddrArray# barr# n#       of { r# ->
 569     (A# r#)}}
 570
 571 indexFloatArray (ByteArray ixs barr#) n
 572   = case (index ixs n)                  of { I# n# ->
 573     case indexFloatArray# barr# n#      of { r# ->
 574     (F# r#)}}
 575
 576 indexDoubleArray (ByteArray ixs barr#) n
 577   = case (index ixs n)                  of { I# n# ->
 578     case indexDoubleArray# barr# n#     of { r# ->
 579     (D# r#)}}
 580
 581 --Indexing off @Addrs@ is similar, and therefore given here.
 582 indexCharOffAddr   :: Addr -> Int -> Char
 583 indexIntOffAddr    :: Addr -> Int -> Int
 584 indexAddrOffAddr   :: Addr -> Int -> Addr
 585 indexFloatOffAddr  :: Addr -> Int -> Float
 586 indexDoubleOffAddr :: Addr -> Int -> Double
 587
 588 indexCharOffAddr (A# addr#) n
 589   = case n                              of { I# n# ->
 590     case indexCharOffAddr# addr# n#     of { r# ->
 591     (C# r#)}}
 592
 593 indexIntOffAddr (A# addr#) n
 594   = case n                              of { I# n# ->
 595     case indexIntOffAddr# addr# n#      of { r# ->
 596     (I# r#)}}
 597
 598 indexAddrOffAddr (A# addr#) n
 599   = case n                              of { I# n# ->
 600     case indexAddrOffAddr# addr# n#     of { r# ->
 601     (A# r#)}}
 602
 603 indexFloatOffAddr (A# addr#) n
 604   = case n                              of { I# n# ->
 605     case indexFloatOffAddr# addr# n#    of { r# ->
 606     (F# r#)}}
 607
 608 indexDoubleOffAddr (A# addr#) n
 609   = case n                              of { I# n# ->
 610     case indexDoubleOffAddr# addr# n#   of { r# ->
 611     (D# r#)}}
 612
 613 writeArray       :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s ()
 614 writeCharArray   :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
 615 writeIntArray    :: Ix ix => MutableByteArray s ix -> ix -> Int  -> ST s ()
 616 writeAddrArray   :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s ()
 617 writeFloatArray  :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
 618 writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
 619
 620 {-# SPECIALIZE writeArray       :: MutableArray s Int elt -> Int -> elt -> ST s (),
 621                                    MutableArray s IPr elt -> IPr -> elt -> ST s ()
 622   #-}
 623 {-# SPECIALIZE writeCharArray   :: MutableByteArray s Int -> Int -> Char -> ST s () #-}
 624 {-# SPECIALIZE writeIntArray    :: MutableByteArray s Int -> Int -> Int  -> ST s () #-}
 625 {-# SPECIALIZE writeAddrArray   :: MutableByteArray s Int -> Int -> Addr -> ST s () #-}
 626 --NO:{-# SPECIALIZE writeFloatArray  :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
 627 {-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
 628
 629 writeArray (MutableArray ixs arr#) n ele = ST $ \ (S# s#) ->
 630     case index ixs n                of { I# n# ->
 631     case writeArray# arr# n# ele s# of { s2# ->
 632     ((), S# s2#)}}
 633
 634 writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ (S# s#) ->
 635     case (index ixs n)                      of { I# n# ->
 636     case writeCharArray# barr# n# ele s#    of { s2#   ->
 637     ((), S# s2#)}}
 638
 639 writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ (S# s#) ->
 640     case (index ixs n)                      of { I# n# ->
 641     case writeIntArray# barr# n# ele s#     of { s2#   ->
 642     ((), S# s2#)}}
 643
 644 writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ (S# s#) ->
 645     case (index ixs n)                      of { I# n# ->
 646     case writeAddrArray# barr# n# ele s#    of { s2#   ->
 647     ((), S# s2#)}}
 648
 649 writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ (S# s#) ->
 650     case (index ixs n)                      of { I# n# ->
 651     case writeFloatArray# barr# n# ele s#   of { s2#   ->
 652     ((), S# s2#)}}
 653
 654 writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ (S# s#) ->
 655     case (index ixs n)                      of { I# n# ->
 656     case writeDoubleArray# barr# n# ele s#  of { s2#   ->
 657     ((), S# s2#)}}
 658
 659 freezeArray       :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
 660 freezeCharArray   :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 661 freezeIntArray    :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 662 freezeAddrArray   :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 663 freezeFloatArray  :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 664 freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 665
 666 {-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt),
 667                               MutableArray s IPr elt -> ST s (Array IPr elt)
 668   #-}
 669 {-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
 670
 671 freezeArray (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 672     let n# = case (if null (range ixs)
 673                   then 0
 674                   else (index ixs ix_end) + 1) of { I# x -> x }
 675     in
 676     case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
 677     (Array ixs frozen#, S# s2#)}
 678   where
 679     freeze  :: MutableArray# s ele      -- the thing
 680             -> Int#                     -- size of thing to be frozen
 681             -> State# s                 -- the Universe and everything
 682             -> StateAndArray# s ele
 683
 684     freeze arr# n# s#
 685       = case newArray# n# init s#             of { StateAndMutableArray# s2# newarr1# ->
 686         case copy 0# n# arr# newarr1# s2#     of { StateAndMutableArray# s3# newarr2# ->
 687         unsafeFreezeArray# newarr2# s3#
 688         }}
 689       where
 690         init = error "freezeArray: element not copied"
 691
 692         copy :: Int# -> Int#
 693              -> MutableArray# s ele -> MutableArray# s ele
 694              -> State# s
 695              -> StateAndMutableArray# s ele
 696
 697         copy cur# end# from# to# s#
 698           | cur# ==# end#
 699             = StateAndMutableArray# s# to#
 700           | True
 701             = case readArray#  from# cur#     s#  of { StateAndPtr# s1# ele ->
 702               case writeArray# to#   cur# ele s1# of { s2# ->
 703               copy (cur# +# 1#) end# from# to# s2#
 704               }}
 705
 706 freezeCharArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 707     let n# = case (if null (range ixs)
 708                   then 0
 709                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 710     in
 711     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 712     (ByteArray ixs frozen#, S# s2#) }
 713   where
 714     freeze  :: MutableByteArray# s      -- the thing
 715             -> Int#                     -- size of thing to be frozen
 716             -> State# s                 -- the Universe and everything
 717             -> StateAndByteArray# s
 718
 719     freeze arr# n# s#
 720       = case (newCharArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 721         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 722         unsafeFreezeByteArray# newarr2# s3#
 723         }}
 724       where
 725         copy :: Int# -> Int#
 726              -> MutableByteArray# s -> MutableByteArray# s
 727              -> State# s
 728              -> StateAndMutableByteArray# s
 729
 730         copy cur# end# from# to# s#
 731           | cur# ==# end#
 732             = StateAndMutableByteArray# s# to#
 733           | True
 734             = case (readCharArray#  from# cur#     s#)  of { StateAndChar# s1# ele ->
 735               case (writeCharArray# to#   cur# ele s1#) of { s2# ->
 736               copy (cur# +# 1#) end# from# to# s2#
 737               }}
 738
 739 freezeIntArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 740     let n# = case (if null (range ixs)
 741                   then 0
 742                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 743     in
 744     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 745     (ByteArray ixs frozen#, S# s2#) }
 746   where
 747     freeze  :: MutableByteArray# s      -- the thing
 748             -> Int#                     -- size of thing to be frozen
 749             -> State# s                 -- the Universe and everything
 750             -> StateAndByteArray# s
 751
 752     freeze arr# n# s#
 753       = case (newIntArray# n# s#)          of { StateAndMutableByteArray# s2# newarr1# ->
 754         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 755         unsafeFreezeByteArray# newarr2# s3#
 756         }}
 757       where
 758         copy :: Int# -> Int#
 759              -> MutableByteArray# s -> MutableByteArray# s
 760              -> State# s
 761              -> StateAndMutableByteArray# s
 762
 763         copy cur# end# from# to# s#
 764           | cur# ==# end#
 765             = StateAndMutableByteArray# s# to#
 766           | True
 767             = case (readIntArray#  from# cur#     s#)  of { StateAndInt# s1# ele ->
 768               case (writeIntArray# to#   cur# ele s1#) of { s2# ->
 769               copy (cur# +# 1#) end# from# to# s2#
 770               }}
 771
 772 freezeAddrArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 773     let n# = case (if null (range ixs)
 774                   then 0
 775                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 776     in
 777     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 778     (ByteArray ixs frozen#, S# s2#) }
 779   where
 780     freeze  :: MutableByteArray# s      -- the thing
 781             -> Int#                     -- size of thing to be frozen
 782             -> State# s                 -- the Universe and everything
 783             -> StateAndByteArray# s
 784
 785     freeze arr# n# s#
 786       = case (newAddrArray# n# s#)         of { StateAndMutableByteArray# s2# newarr1# ->
 787         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 788         unsafeFreezeByteArray# newarr2# s3#
 789         }}
 790       where
 791         copy :: Int# -> Int#
 792              -> MutableByteArray# s -> MutableByteArray# s
 793              -> State# s
 794              -> StateAndMutableByteArray# s
 795
 796         copy cur# end# from# to# s#
 797           | cur# ==# end#
 798             = StateAndMutableByteArray# s# to#
 799           | True
 800             = case (readAddrArray#  from# cur#     s#)  of { StateAndAddr# s1# ele ->
 801               case (writeAddrArray# to#   cur# ele s1#) of { s2# ->
 802               copy (cur# +# 1#) end# from# to# s2#
 803               }}
 804
 805 freezeFloatArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 806     let n# = case (if null (range ixs)
 807                   then 0
 808                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 809     in
 810     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 811     (ByteArray ixs frozen#, S# s2#) }
 812   where
 813     freeze  :: MutableByteArray# s      -- the thing
 814             -> Int#                     -- size of thing to be frozen
 815             -> State# s                 -- the Universe and everything
 816             -> StateAndByteArray# s
 817
 818     freeze arr# n# s#
 819       = case (newFloatArray# n# s#)        of { StateAndMutableByteArray# s2# newarr1# ->
 820         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 821         unsafeFreezeByteArray# newarr2# s3#
 822         }}
 823       where
 824         copy :: Int# -> Int#
 825              -> MutableByteArray# s -> MutableByteArray# s
 826              -> State# s
 827              -> StateAndMutableByteArray# s
 828
 829         copy cur# end# from# to# s#
 830           | cur# ==# end#
 831             = StateAndMutableByteArray# s# to#
 832           | True
 833             = case (readFloatArray#  from# cur#     s#)  of { StateAndFloat# s1# ele ->
 834               case (writeFloatArray# to#   cur# ele s1#) of { s2# ->
 835               copy (cur# +# 1#) end# from# to# s2#
 836               }}
 837
 838 freezeDoubleArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 839     let n# = case (if null (range ixs)
 840                   then 0
 841                   else ((index ixs ix_end) + 1)) of { I# x -> x }
 842     in
 843     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
 844     (ByteArray ixs frozen#, S# s2#) }
 845   where
 846     freeze  :: MutableByteArray# s      -- the thing
 847             -> Int#                     -- size of thing to be frozen
 848             -> State# s                 -- the Universe and everything
 849             -> StateAndByteArray# s
 850
 851     freeze arr# n# s#
 852       = case (newDoubleArray# n# s#)       of { StateAndMutableByteArray# s2# newarr1# ->
 853         case copy 0# n# arr# newarr1# s2#  of { StateAndMutableByteArray# s3# newarr2# ->
 854         unsafeFreezeByteArray# newarr2# s3#
 855         }}
 856       where
 857         copy :: Int# -> Int#
 858              -> MutableByteArray# s -> MutableByteArray# s
 859              -> State# s
 860              -> StateAndMutableByteArray# s
 861
 862         copy cur# end# from# to# s#
 863           | cur# ==# end#
 864             = StateAndMutableByteArray# s# to#
 865           | True
 866             = case (readDoubleArray#  from# cur#     s#)  of { StateAndDouble# s1# ele ->
 867               case (writeDoubleArray# to#   cur# ele s1#) of { s2# ->
 868               copy (cur# +# 1#) end# from# to# s2#
 869               }}
 870
 871 unsafeFreezeArray     :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
 872 unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 873
 874 {-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int)
 875   #-}
 876
 877 unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) ->
 878     case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
 879     (Array ixs frozen#, S# s2#) }
 880
 881 unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
 882     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 883     (ByteArray ixs frozen#, S# s2#) }
 884
 885
 886 --This takes a immutable array, and copies it into a mutable array, in a
 887 --hurry.
 888
 889 {-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt),
 890                             Array IPr elt -> ST s (MutableArray s IPr elt)
 891   #-}
 892
 893 thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
 894     let n# = case (if null (range ixs)
 895                   then 0
 896                   else (index ixs ix_end) + 1) of { I# x -> x }
 897     in
 898     case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
 899     (MutableArray ixs thawed#, S# s2#)}
 900   where
 901     thaw  :: Array# ele                 -- the thing
 902             -> Int#                     -- size of thing to be thawed
 903             -> State# s                 -- the Universe and everything
 904             -> StateAndMutableArray# s ele
 905
 906     thaw arr# n# s#
 907       = case newArray# n# init s#             of { StateAndMutableArray# s2# newarr1# ->
 908         copy 0# n# arr# newarr1# s2# }
 909       where
 910         init = error "thawArray: element not copied"
 911
 912         copy :: Int# -> Int#
 913              -> Array# ele
 914              -> MutableArray# s ele
 915              -> State# s
 916              -> StateAndMutableArray# s ele
 917
 918         copy cur# end# from# to# s#
 919           | cur# ==# end#
 920             = StateAndMutableArray# s# to#
 921           | True
 922             = case indexArray#  from# cur#       of { Lift ele ->
 923               case writeArray# to#   cur# ele s# of { s1# ->
 924               copy (cur# +# 1#) end# from# to# s1#
 925               }}
 926
 927 sameMutableArray     :: MutableArray s ix elt -> MutableArray s ix elt -> Bool
 928 sameMutableByteArray :: MutableByteArray s ix -> MutableByteArray s ix -> Bool
 929
 930 sameMutableArray (MutableArray _ arr1#) (MutableArray _ arr2#)
 931   = sameMutableArray# arr1# arr2#
 932
 933 sameMutableByteArray (MutableByteArray _ arr1#) (MutableByteArray _ arr2#)
 934   = sameMutableByteArray# arr1# arr2#
 935
 936 {- =============================================================
 937 ** VARIABLES, including MVars and IVars
 938 -}
 939
 940 --************************************************************************
 941 -- Variables
 942
 943 type MutableVar s a = MutableArray s Int a
 944
 945 newVar   :: a -> ST s (MutableVar s a)
 946 readVar  :: MutableVar s a -> ST s a
 947 writeVar :: MutableVar s a -> a -> ST s ()
 948 sameVar  :: MutableVar s a -> MutableVar s a -> Bool
 949
 950 newVar init = ST $ \ (S# s#) ->
 951     case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 952     (MutableArray vAR_IXS arr#, S# s2#) }
 953   where
 954     vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n"
 955
 956 readVar (MutableArray _ var#) = ST $ \ (S# s#) ->
 957     case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 958     (r, S# s2#) }
 959
 960 writeVar (MutableArray _ var#) val = ST $ \ (S# s#) ->
 961     case writeArray# var# 0# val s# of { s2# ->
 962     ((), S# s2#) }
 963
 964 sameVar (MutableArray _ var1#) (MutableArray _ var2#)
 965   = sameMutableArray# var1# var2#
 966
 967 --%************************************************************************
 968 --%*                                                                    *
 969 --\subsection[PreludeGlaST-mvars]{M-Structures}
 970 --%*                                                                    *
 971 --%************************************************************************
 972 {-
 973 M-Vars are rendezvous points for concurrent threads.  They begin
 974 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 975 is written, a single blocked thread may be freed.  Reading an M-Var
 976 toggles its state from full back to empty.  Therefore, any value
 977 written to an M-Var may only be read once.  Multiple reads and writes
 978 are allowed, but there must be at least one read between any two
 979 writes.
 980 -}
 981
 982 data MVar a = MVar (SynchVar# RealWorld a)
 983
 984 newEmptyMVar  :: IO (MVar a)
 985
 986 newEmptyMVar = IO $ ST $ \ (S# s#) ->
 987     case newSynchVar# s# of
 988         StateAndSynchVar# s2# svar# -> (Right (MVar svar#), S# s2#)
 989
 990 takeMVar :: MVar a -> IO a
 991
 992 takeMVar (MVar mvar#) = IO $ ST $ \ (S# s#) ->
 993     case takeMVar# mvar# s# of
 994         StateAndPtr# s2# r -> (Right r, S# s2#)
 995
 996 putMVar  :: MVar a -> a -> IO ()
 997
 998 putMVar (MVar mvar#) x = IO $ ST $ \ (S# s#) ->
 999     case putMVar# mvar# x s# of
1000         s2# -> (Right (), S# s2#)
1001
1002 newMVar :: a -> IO (MVar a)
1003
1004 newMVar value =
1005     newEmptyMVar        >>= \ mvar ->
1006     putMVar mvar value  >>
1007     return mvar
1008
1009 readMVar :: MVar a -> IO a
1010
1011 readMVar mvar =
1012     takeMVar mvar       >>= \ value ->
1013     putMVar mvar value  >>
1014     return value
1015
1016 swapMVar :: MVar a -> a -> IO a
1017
1018 swapMVar mvar new =
1019     takeMVar mvar       >>= \ old ->
1020     putMVar mvar new    >>
1021     return old
1022
1023 --%************************************************************************
1024 --%*                                                                    *
1025 --\subsection[PreludeGlaST-ivars]{I-Structures}
1026 --%*                                                                    *
1027 --%************************************************************************
1028 {-
1029 I-Vars are write-once variables.  They start out empty, and any threads that
1030 attempt to read them will block until they are filled.  Once they are written,
1031 any blocked threads are freed, and additional reads are permitted.  Attempting
1032 to write a value to a full I-Var results in a runtime error.
1033 -}
1034 data IVar a = IVar (SynchVar# RealWorld a)
1035
1036 newIVar :: IO (IVar a)
1037
1038 newIVar = IO $ ST $ \ (S# s#) ->
1039     case newSynchVar# s# of
1040         StateAndSynchVar# s2# svar# -> (Right (IVar svar#), S# s2#)
1041
1042 readIVar :: IVar a -> IO a
1043
1044 readIVar (IVar ivar#) = IO $ ST $ \ (S# s#) ->
1045     case readIVar# ivar# s# of
1046         StateAndPtr# s2# r -> (Right r, S# s2#)
1047
1048 writeIVar :: IVar a -> a -> IO ()
1049
1050 writeIVar (IVar ivar#) x = IO $ ST $ \ (S# s#) ->
1051     case writeIVar# ivar# x s# of
1052         s2# -> (Right (), S# s2#)
1053
1054 {- =============================================================
1055 ** THREAD WAITING
1056 -}
1057
1058 {-
1059 @threadDelay@ delays rescheduling of a thread until the indicated
1060 number of microseconds have elapsed.  Generally, the microseconds are
1061 counted by the context switch timer, which ticks in virtual time;
1062 however, when there are no runnable threads, we don't accumulate any
1063 virtual time, so we start ticking in real time.  (The granularity is
1064 the effective resolution of the context switch timer, so it is
1065 affected by the RTS -C option.)
1066
1067 @threadWait@ delays rescheduling of a thread until input on the
1068 specified file descriptor is available for reading (just like select).
1069 -}
1070
1071 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
1072
1073 threadDelay (I# x#) = IO $ ST $ \ (S# s#) ->
1074     case delay# x# s# of
1075       s2# -> (Right (), S# s2#)
1076
1077 threadWaitRead (I# x#) = IO $ ST $ \ (S# s#) ->
1078     case waitRead# x# s# of
1079       s2# -> (Right (), S# s2#)
1080
1081 threadWaitWrite (I# x#) = IO $ ST $ \ (S# s#) ->
1082     case waitWrite# x# s# of
1083       s2# -> (Right (), S# s2#)
1084
1085 {- =============================================================
1086 ** OTHER SUPPORT FUNCTIONS
1087
1088    3 flavors, basically: string support, error/trace-ish, and read/show-ish.
1089 -}
1090 seq, par, fork :: Eval a => a -> b -> b
1091
1092 {-# INLINE seq  #-}
1093 {-# INLINE par  #-}
1094 {-# INLINE fork #-}
1095
1096 seq  x y = case (seq#  x) of { 0# -> parError; _ -> y }
1097 par  x y = case (par#  x) of { 0# -> parError; _ -> y }
1098 fork x y = case (fork# x) of { 0# -> parError; _ -> y }
1099
1100 ---------------------------------------------------------------
1101 -- HACK: Magic unfoldings not implemented for unboxed lists
1102 --       Need to define a "build" to avoid undefined symbol
1103
1104 build   = error "GHCbase.build"
1105 augment = error "GHCbase.augment"
1106 --{-# GENERATE_SPECS build a #-}
1107 --build                 :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
1108 --build g       = g (:) []
1109
1110
1111 ---------------------------------------------------------------
1112 -- string-support functions:
1113 ---------------------------------------------------------------
1114
1115 --------------------------------------------------------------------------
1116
1117 packStringForC__ :: [Char]          -> ByteArray# -- calls injected by compiler
1118 unpackPS__       :: Addr#           -> [Char] -- calls injected by compiler
1119 unpackPS2__      :: Addr# -> Int#   -> [Char] -- calls injected by compiler
1120 unpackAppendPS__ :: Addr# -> [Char] -> [Char] -- ditto?
1121 unpackFoldrPS__  :: Addr# -> (Char  -> a -> a) -> a -> a -- ditto?
1122
1123 packStringForC__ str = case (GHCps.packString str) of { PS bytes _ _ -> bytes}
1124
1125 unpackPS__ addr -- calls injected by compiler
1126   = unpack 0#
1127   where
1128     unpack nh
1129       | ch `eqChar#` '\0'# = []
1130       | True               = C# ch : unpack (nh +# 1#)
1131       where
1132         ch = indexCharOffAddr# addr nh
1133
1134 unpackAppendPS__ addr rest
1135   = unpack 0#
1136   where
1137     unpack nh
1138       | ch `eqChar#` '\0'# = rest
1139       | True               = C# ch : unpack (nh +# 1#)
1140       where
1141         ch = indexCharOffAddr# addr nh
1142
1143 unpackFoldrPS__ addr f z
1144   = unpack 0#
1145   where
1146     unpack nh
1147       | ch `eqChar#` '\0'# = z
1148       | True               = C# ch `f` unpack (nh +# 1#)
1149       where
1150         ch = indexCharOffAddr# addr nh
1151
1152 unpackPS2__ addr len -- calls injected by compiler
1153   -- this one is for literal strings with NULs in them; rare.
1154   = GHCps.unpackPS (GHCps.packCBytes (I# len) (A# addr))
1155
1156 ---------------------------------------------------------------
1157 -- injected literals:
1158 ---------------------------------------------------------------
1159 integer_0, integer_1, integer_2, integer_m1 :: Integer
1160
1161 integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
1162
1163 ---------------------------------------------------------------
1164 -- error/trace-ish functions:
1165 ---------------------------------------------------------------
1166
1167 errorIO :: PrimIO () -> a
1168
1169 errorIO (ST io)
1170   = case (errorIO# io) of
1171       _ -> bottom
1172   where
1173     bottom = bottom -- Never evaluated
1174
1175 error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
1176
1177 error__ msg_hdr s
1178 #ifdef __PARALLEL_HASKELL__
1179   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
1180              _ccall_ fflush sTDERR      >>
1181              fputs sTDERR s             >>
1182              _ccall_ fflush sTDERR      >>
1183              _ccall_ stg_exit (1::Int)
1184             )
1185 #else
1186   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
1187              _ccall_ fflush sTDERR      >>
1188              fputs sTDERR s             >>
1189              _ccall_ fflush sTDERR      >>
1190              _ccall_ getErrorHandler    >>= \ errorHandler ->
1191              if errorHandler == (-1::Int) then
1192                 _ccall_ stg_exit (1::Int)
1193              else
1194                 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
1195                                                 >>= \ osptr ->
1196                 _ccall_ decrementErrorCount     >>= \ () ->
1197                 deRefStablePtr osptr            >>= \ oact ->
1198                 oact
1199             )
1200 #endif {- !parallel -}
1201   where
1202     sTDERR = (``stderr'' :: Addr)
1203
1204 ---------------
1205
1206 fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
1207
1208 fputs stream [] = return True
1209
1210 fputs stream (c : cs)
1211   = _ccall_ stg_putc c stream >> -- stg_putc expands to putc
1212     fputs stream cs              -- (just does some casting stream)
1213
1214 ---------------------------------------------------------------
1215 -- Used for compiler-generated error message;
1216 -- encoding saves bytes of string junk.
1217
1218 absentErr, parError :: a
1219 irrefutPatError
1220  , noDefaultMethodError
1221  , noExplicitMethodError
1222  , nonExhaustiveGuardsError
1223  , patError
1224  , recConError
1225  , recUpdError :: String -> a
1226
1227 absentErr = error "Oops! The program has entered an `absent' argument!\n"
1228 parError  = error "Oops! Entered GHCbase.parError (a GHC bug -- please report it!)\n"
1229
1230 irrefutPatError          s = error ("irrefutPatError:"++s)
1231 noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
1232 noExplicitMethodError    s = error ("noExplicitMethodError:"++s)
1233 nonExhaustiveGuardsError s = error ("nonExhaustiveGuardsError:"++s)
1234
1235 patError msg
1236   = error__ (\ x -> _ccall_ PatErrorHdrHook x) ("Pattern-matching failed in: "++msg++"\n")
1237 recConError s = error ("recConError:"++s)
1238 recUpdError s = error ("recUpdError:"++s)
1239
1240 ---------------------------------------------------------------
1241 -- ******** defn of `_trace' using Glasgow IO *******
1242
1243 {-# GENERATE_SPECS _trace a #-}
1244
1245 trace :: String -> a -> a
1246
1247 trace string expr
1248   = unsafePerformPrimIO (
1249         ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ())  >>
1250         fputs sTDERR string                                 >>
1251         ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
1252         returnPrimIO expr )
1253   where
1254     sTDERR = (``stderr'' :: Addr)
1255
1256 ---------------------------------------------------------------
1257 -- read/show-ish functions:
1258 ---------------------------------------------------------------
1259 {-# GENERATE_SPECS readList__ a #-}
1260 readList__ :: ReadS a -> ReadS [a]
1261
1262 readList__ readx
1263   = readParen False (\r -> [pr | ("[",s)  <- lex r, pr <- readl s])
1264   where readl  s = [([],t)   | ("]",t)  <- lex s] ++
1265                    [(x:xs,u) | (x,t)    <- readx s,
1266                                (xs,u)   <- readl2 t]
1267         readl2 s = [([],t)   | ("]",t)  <- lex s] ++
1268                    [(x:xs,v) | (",",t)  <- lex s,
1269                                (x,u)    <- readx t,
1270                                (xs,v)   <- readl2 u]
1271
1272 {-# GENERATE_SPECS showList__ a #-}
1273 showList__ :: (a -> ShowS) ->  [a] -> ShowS
1274
1275 showList__ showx []     = showString "[]"
1276 showList__ showx (x:xs) = showChar '[' . showx x . showl xs
1277   where
1278     showl []     = showChar ']'
1279     showl (x:xs) = showString ", " . showx x . showl xs
1280
1281 showSpace :: ShowS
1282 showSpace = {-showChar ' '-} \ xs -> ' ' : xs
1283
1284 -- ******************************************************************
1285
1286 -- This lexer is not completely faithful to the Haskell lexical syntax.
1287 -- Current limitations:
1288 --    Qualified names are not handled properly
1289 --    A `--' does not terminate a symbol
1290 --    Octal and hexidecimal numerics are not recognized as a single token
1291
1292 lex                   :: ReadS String
1293 lex ""                = [("","")]
1294 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1295 lex ('\'':s)          = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
1296                                               ch /= "'"                ]
1297 lex ('"':s)           = [('"':str, t)      | (str,t) <- lexString s]
1298                         where
1299                         lexString ('"':s) = [("\"",s)]
1300                         lexString s = [(ch++str, u)
1301                                               | (ch,t)  <- lexStrItem s,
1302                                                 (str,u) <- lexString t  ]
1303
1304                         lexStrItem ('\\':'&':s) = [("\\&",s)]
1305                         lexStrItem ('\\':c:s) | isSpace c
1306                             = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
1307                         lexStrItem s            = lexLitChar s
1308
1309 lex (c:s) | isSingle c = [([c],s)]
1310           | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]
1311           | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]
1312           | isDigit c  = [(c:ds++fe,t)    | (ds,s)  <- [span isDigit s],
1313                                             (fe,t)  <- lexFracExp s     ]
1314           | otherwise  = []    -- bad character
1315              where
1316               isSingle c =  c `elem` ",;()[]{}_`"
1317               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
1318               isIdChar c =  isAlphanum c || c `elem` "_'"
1319
1320               lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1321                                                     (e,u)  <- lexExp t]
1322               lexFracExp s       = [("",s)]
1323
1324               lexExp (e:s) | e `elem` "eE"
1325                        = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
1326                                                  (ds,u) <- lexDigits t] ++
1327                          [(e:ds,t)   | (ds,t) <- lexDigits s]
1328               lexExp s = [("",s)]
1329
1330 lexDigits               :: ReadS String
1331 lexDigits               =  nonnull isDigit
1332
1333 nonnull                 :: (Char -> Bool) -> ReadS String
1334 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
1335
1336 lexLitChar              :: ReadS String
1337 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
1338         where
1339         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
1340         lexEsc s@(d:_)   | isDigit d               = lexDigits s
1341         lexEsc _                                   = []
1342 lexLitChar (c:s)        =  [([c],s)]
1343 lexLitChar ""           =  []
1344
1345
1346 match                   :: (Eq a) => [a] -> [a] -> ([a],[a])
1347 match (x:xs) (y:ys) | x == y  =  match xs ys
1348 match xs     ys               =  (xs,ys)
1349
1350 asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
1351            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1352             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
1353             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1354             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
1355             "SP"]
1356
1357 readLitChar             :: ReadS Char
1358
1359 readLitChar ('\\':s)    =  readEsc s
1360         where
1361         readEsc ('a':s)  = [('\a',s)]
1362         readEsc ('b':s)  = [('\b',s)]
1363         readEsc ('f':s)  = [('\f',s)]
1364         readEsc ('n':s)  = [('\n',s)]
1365         readEsc ('r':s)  = [('\r',s)]
1366         readEsc ('t':s)  = [('\t',s)]
1367         readEsc ('v':s)  = [('\v',s)]
1368         readEsc ('\\':s) = [('\\',s)]
1369         readEsc ('"':s)  = [('"',s)]
1370         readEsc ('\'':s) = [('\'',s)]
1371         readEsc ('^':c:s) | c >= '@' && c <= '_'
1372                          = [(chr (ord c - ord '@'), s)]
1373         readEsc s@(d:_) | isDigit d
1374                          = [(chr n, t) | (n,t) <- readDec s]
1375         readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
1376         readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
1377         readEsc s@(c:_) | isUpper c
1378                          = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
1379                            in case [(c,s') | (c, mne) <- table,
1380                                              ([],s') <- [match mne s]]
1381                               of (pr:_) -> [pr]
1382                                  []     -> []
1383         readEsc _        = []
1384 readLitChar (c:s)       =  [(c,s)]
1385
1386 showLitChar                :: Char -> ShowS
1387 showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
1388 showLitChar '\DEL'         =  showString "\\DEL"
1389 showLitChar '\\'           =  showString "\\\\"
1390 showLitChar c | c >= ' '   =  showChar c
1391 showLitChar '\a'           =  showString "\\a"
1392 showLitChar '\b'           =  showString "\\b"
1393 showLitChar '\f'           =  showString "\\f"
1394 showLitChar '\n'           =  showString "\\n"
1395 showLitChar '\r'           =  showString "\\r"
1396 showLitChar '\t'           =  showString "\\t"
1397 showLitChar '\v'           =  showString "\\v"
1398 showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")
1399 showLitChar c              =  showString ('\\' : asciiTab!!ord c)
1400
1401 protectEsc p f             = f . cont
1402                              where cont s@(c:_) | p c = "\\&" ++ s
1403                                    cont s             = s
1404
1405 -- ******************************************************************
1406
1407 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
1408 readDec :: (Integral a) => ReadS a
1409 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
1410
1411 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
1412 readOct :: (Integral a) => ReadS a
1413 readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
1414
1415 {-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
1416 readHex :: (Integral a) => ReadS a
1417 readHex = readInt 16 isHexDigit hex
1418             where hex d = ord d - (if isDigit d then ord_0
1419                                    else ord (if isUpper d then 'A' else 'a') - 10)
1420
1421 {-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
1422 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1423 readInt radix isDig digToInt s =
1424     [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
1425         | (ds,r) <- nonnull isDig s ]
1426
1427 showInt n r
1428   = case quotRem n 10 of                     { (n', d) ->
1429     case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
1430     let
1431         r' = C# c# : r
1432     in
1433     if n' == 0 then r' else showInt n' r'
1434     }}
1435
1436 -- ******************************************************************
1437
1438 {-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
1439 readSigned :: (Real a) => ReadS a -> ReadS a
1440 readSigned readPos = readParen False read'
1441                      where read' r  = read'' r ++
1442                                       [(-x,t) | ("-",s) <- lex r,
1443                                                 (x,t)   <- read'' s]
1444                            read'' r = [(n,s)  | (str,s) <- lex r,
1445                                                 (n,"")  <- readPos str]
1446
1447
1448 {-# SPECIALIZE showSigned :: (Int     -> ShowS) -> Int -> Int     -> ShowS = showSigned_Int,
1449                              (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer #-}
1450 {-# GENERATE_SPECS showSigned a{Double#,Double} #-}
1451 showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
1452 showSigned showPos p x = if x < 0 then showParen (p > 6)
1453                                                  (showChar '-' . showPos (-x))
1454                                   else showPos x
1455
1456 showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS
1457 showSigned_Int _ p n r
1458   = -- from HBC version; support code follows
1459     if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r
1460
1461 showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS
1462 showSigned_Integer _ p n r
1463   = -- from HBC version; support code follows
1464     if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
1465
1466 -- ******************************************************************
1467
1468 itos# :: Int# -> String
1469 itos# n =
1470     if n `ltInt#` 0# then
1471         if negateInt# n `ltInt#` 0# then
1472             -- n is minInt, a difficult number
1473             itos# (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) []
1474         else
1475             '-':itos' (negateInt# n) []
1476     else
1477         itos' n []
1478   where
1479     itos' :: Int# -> String -> String
1480     itos' n cs =
1481         if n `ltInt#` 10# then
1482             C# (chr# (n `plusInt#` ord# '0'#)) : cs
1483         else
1484             itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs)
1485
1486 itos :: Int -> String
1487 itos (I# n) = itos# n
1488
1489 jtos :: Integer -> String
1490 jtos n
1491   = if n < 0 then
1492         '-' : jtos' (-n) []
1493     else
1494         jtos' n []
1495
1496 jtos' :: Integer -> String -> String
1497 jtos' n cs
1498   = if n < 10 then
1499         chr (fromInteger (n + ord_0)) : cs
1500     else
1501         jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs)
1502
1503 chr = (toEnum   :: Int  -> Char)
1504 ord = (fromEnum :: Char -> Int)
1505
1506 ord_0 :: Num a => a
1507 ord_0 = fromInt (ord '0')
1508
1509 -- ******************************************************************
1510
1511 -- The functions readFloat and showFloat below use rational arithmetic
1512 -- to insure correct conversion between the floating-point radix and
1513 -- decimal.  It is often possible to use a higher-precision floating-
1514 -- point type to obtain the same results.
1515
1516 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
1517 readFloat :: (RealFloat a) => ReadS a
1518 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
1519
1520 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
1521
1522 readRational r
1523   = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
1524                                (k,t)   <- readExp s]
1525               where readFix r = [(read (ds++ds'), length ds', t)
1526                                         | (ds,'.':s) <- lexDigits r,
1527                                           (ds',t)    <- lexDigits s ]
1528
1529                     readExp (e:s) | e `elem` "eE" = readExp' s
1530                     readExp s                     = [(0,s)]
1531
1532                     readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1533                     readExp' ('+':s) = readDec s
1534                     readExp' s       = readDec s
1535
1536 readRational__ :: String -> Rational -- we export this one (non-std)
1537                                     -- NB: *does* handle a leading "-"
1538 readRational__ top_s
1539   = case top_s of
1540       '-' : xs -> - (read_me xs)
1541       xs       -> read_me xs
1542   where
1543     read_me s
1544       = case [x | (x,t) <- readRational s, ("","") <- lex t] of
1545           [x] -> x
1546           []  -> error ("readRational__: no parse:"        ++ top_s)
1547           _   -> error ("readRational__: ambiguous parse:" ++ top_s)
1548
1549 -- The number of decimal digits m below is chosen to guarantee
1550 -- read (show x) == x.  See
1551 --      Matula, D. W.  A formalization of floating-point numeric base
1552 --      conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
1553 --      681-692.
1554
1555 zeros = repeat '0'
1556
1557 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
1558 showFloat:: (RealFloat a) => a -> ShowS
1559 showFloat x =
1560     if x == 0 then showString ("0." ++ take (m-1) zeros)
1561               else if e >= m-1 || e < 0 then showSci else showFix
1562     where
1563     showFix     = showString whole . showChar '.' . showString frac
1564                   where (whole,frac) = splitAt (e+1) (show sig)
1565     showSci     = showChar d . showChar '.' . showString frac
1566                       . showChar 'e' . shows e
1567                   where (d:frac) = show sig
1568     (m, sig, e) = if b == 10 then (w,   s,   n+w-1)
1569                              else (m', sig', e'   )
1570     m'          = ceiling
1571                       ((fromInt w * log (fromInteger b)) / log 10 :: Double)
1572                   + 1
1573     (sig', e')  = if      sig1 >= 10^m'     then (round (t/10), e1+1)
1574                   else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
1575                                             else (sig1,          e1  )
1576     sig1        = round t
1577     t           = s%1 * (b%1)^^n * 10^^(m'-e1-1)
1578     e1          = floor (logBase 10 x)
1579     (s, n)      = decodeFloat x
1580     b           = floatRadix x
1581     w           = floatDigits x
1582
1583 ---------------------------------------------------------
1584 -- definitions of the boxed PrimOps; these will be
1585 -- used in the case of partial applications, etc.
1586
1587 plusInt (I# x) (I# y) = I# (plusInt# x y)
1588 minusInt(I# x) (I# y) = I# (minusInt# x y)
1589 timesInt(I# x) (I# y) = I# (timesInt# x y)
1590 quotInt (I# x) (I# y) = I# (quotInt# x y)
1591 remInt  (I# x) (I# y) = I# (remInt# x y)
1592 negateInt (I# x)      = I# (negateInt# x)
1593 gtInt   (I# x) (I# y) = gtInt# x y
1594 geInt   (I# x) (I# y) = geInt# x y
1595 eqInt   (I# x) (I# y) = eqInt# x y
1596 neInt   (I# x) (I# y) = neInt# x y
1597 ltInt   (I# x) (I# y) = ltInt# x y
1598 leInt   (I# x) (I# y) = leInt# x y
1599
1600 -- definitions of the boxed PrimOps; these will be
1601 -- used in the case of partial applications, etc.
1602
1603 plusFloat   (F# x) (F# y) = F# (plusFloat# x y)
1604 minusFloat  (F# x) (F# y) = F# (minusFloat# x y)
1605 timesFloat  (F# x) (F# y) = F# (timesFloat# x y)
1606 divideFloat (F# x) (F# y) = F# (divideFloat# x y)
1607 negateFloat (F# x)        = F# (negateFloat# x)
1608
1609 gtFloat     (F# x) (F# y) = gtFloat# x y
1610 geFloat     (F# x) (F# y) = geFloat# x y
1611 eqFloat     (F# x) (F# y) = eqFloat# x y
1612 neFloat     (F# x) (F# y) = neFloat# x y
1613 ltFloat     (F# x) (F# y) = ltFloat# x y
1614 leFloat     (F# x) (F# y) = leFloat# x y
1615
1616 float2Int   (F# x) = I# (float2Int# x)
1617 int2Float   (I# x) = F# (int2Float# x)
1618
1619 expFloat    (F# x) = F# (expFloat# x)
1620 logFloat    (F# x) = F# (logFloat# x)
1621 sqrtFloat   (F# x) = F# (sqrtFloat# x)
1622 sinFloat    (F# x) = F# (sinFloat# x)
1623 cosFloat    (F# x) = F# (cosFloat# x)
1624 tanFloat    (F# x) = F# (tanFloat# x)
1625 asinFloat   (F# x) = F# (asinFloat# x)
1626 acosFloat   (F# x) = F# (acosFloat# x)
1627 atanFloat   (F# x) = F# (atanFloat# x)
1628 sinhFloat   (F# x) = F# (sinhFloat# x)
1629 coshFloat   (F# x) = F# (coshFloat# x)
1630 tanhFloat   (F# x) = F# (tanhFloat# x)
1631
1632 powerFloat  (F# x) (F# y) = F# (powerFloat# x y)
1633
1634 -- definitions of the boxed PrimOps; these will be
1635 -- used in the case of partial applications, etc.
1636
1637 plusDouble   (D# x) (D# y) = D# (plusDouble# x y)
1638 minusDouble  (D# x) (D# y) = D# (minusDouble# x y)
1639 timesDouble  (D# x) (D# y) = D# (timesDouble# x y)
1640 divideDouble (D# x) (D# y) = D# (divideDouble# x y)
1641 negateDouble (D# x)        = D# (negateDouble# x)
1642
1643 gtDouble    (D# x) (D# y) = gtDouble# x y
1644 geDouble    (D# x) (D# y) = geDouble# x y
1645 eqDouble    (D# x) (D# y) = eqDouble# x y
1646 neDouble    (D# x) (D# y) = neDouble# x y
1647 ltDouble    (D# x) (D# y) = ltDouble# x y
1648 leDouble    (D# x) (D# y) = leDouble# x y
1649
1650 double2Int   (D# x) = I# (double2Int#   x)
1651 int2Double   (I# x) = D# (int2Double#   x)
1652 double2Float (D# x) = F# (double2Float# x)
1653 float2Double (F# x) = D# (float2Double# x)
1654
1655 expDouble    (D# x) = D# (expDouble# x)
1656 logDouble    (D# x) = D# (logDouble# x)
1657 sqrtDouble   (D# x) = D# (sqrtDouble# x)
1658 sinDouble    (D# x) = D# (sinDouble# x)
1659 cosDouble    (D# x) = D# (cosDouble# x)
1660 tanDouble    (D# x) = D# (tanDouble# x)
1661 asinDouble   (D# x) = D# (asinDouble# x)
1662 acosDouble   (D# x) = D# (acosDouble# x)
1663 atanDouble   (D# x) = D# (atanDouble# x)
1664 sinhDouble   (D# x) = D# (sinhDouble# x)
1665 coshDouble   (D# x) = D# (coshDouble# x)
1666 tanhDouble   (D# x) = D# (tanhDouble# x)
1667
1668 powerDouble  (D# x) (D# y) = D# (powerDouble# x y)
1669
1670 ---------------------------------------------------------
1671 {-
1672 [In response to a request by simonpj, Joe Fasel writes:]
1673
1674 A quite reasonable request!  This code was added to the Prelude just
1675 before the 1.2 release, when Lennart, working with an early version
1676 of hbi, noticed that (read . show) was not the identity for
1677 floating-point numbers.  (There was a one-bit error about half the time.)
1678 The original version of the conversion function was in fact simply
1679 a floating-point divide, as you suggest above.  The new version is,
1680 I grant you, somewhat denser.
1681
1682 How's this?
1683
1684 Joe
1685 -}
1686
1687 {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
1688 fromRational__ :: (RealFloat a) => Rational -> a
1689 fromRational__ x = x'
1690         where x' = f e
1691
1692 --              If the exponent of the nearest floating-point number to x
1693 --              is e, then the significand is the integer nearest xb^(-e),
1694 --              where b is the floating-point radix.  We start with a good
1695 --              guess for e, and if it is correct, the exponent of the
1696 --              floating-point number we construct will again be e.  If
1697 --              not, one more iteration is needed.
1698
1699               f e   = if e' == e then y else f e'
1700                       where y      = encodeFloat (round (x * (1 % b)^^e)) e
1701                             (_,e') = decodeFloat y
1702               b     = floatRadix x'
1703
1704 --              We obtain a trial exponent by doing a floating-point
1705 --              division of x's numerator by its denominator.  The
1706 --              result of this division may not itself be the ultimate
1707 --              result, because of an accumulation of three rounding
1708 --              errors.
1709
1710               (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
1711                                         / fromInteger (denominator x))
1712
1713 -------------------------------------------------------------------------
1714 -- from/by Lennart, 94/09/26
1715
1716 -- Convert a Rational to a string that looks like a floating point number,
1717 -- but without converting to any floating type (because of the possible overflow).
1718 showRational :: Int -> Rational -> String
1719 showRational n r =
1720     if r == 0 then
1721         "0.0"
1722     else
1723         let (r', e) = normalize r
1724         in  prR n r' e
1725
1726 startExpExp = 4 :: Int
1727
1728 -- make sure 1 <= r < 10
1729 normalize :: Rational -> (Rational, Int)
1730 normalize r = if r < 1 then
1731                   case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1)
1732               else
1733                   norm startExpExp r 0
1734         where norm :: Int -> Rational -> Int -> (Rational, Int)
1735               -- Invariant: r*10^e == original r
1736               norm 0  r e = (r, e)
1737               norm ee r e =
1738                 let n = 10^ee
1739                     tn = 10^n
1740                 in  if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
1741
1742 drop0 "" = ""
1743 drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
1744
1745 prR :: Int -> Rational -> Int -> String
1746 prR n r e | r <  1  = prR n (r*10) (e-1)                -- final adjustment
1747 prR n r e | r >= 10 = prR n (r/10) (e+1)
1748 prR n r e0 =
1749         let s = show ((round (r * 10^n))::Integer)
1750             e = e0+1
1751         in  if e > 0 && e < 8 then
1752                 take e s ++ "." ++ drop0 (drop e s)
1753             else if e <= 0 && e > -3 then
1754                 "0." ++ take (-e) (repeat '0') ++ drop0 s
1755             else
1756                 head s : "."++ drop0 (tail s) ++ "e" ++ show e0