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