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"
6 Users should not import it directly.
10 import Array ( array, bounds, assocs )
11 import Char (isDigit,isUpper,isSpace,isAlphanum,isAlpha,isOctDigit,isHexDigit)
14 import qualified GHCps ( packString, packCBytes, comparePS, unpackPS )
15 import qualified GHCio ( IOError )
16 import qualified Monad
18 infixr 0 `seq`, `par`, `fork`
20 {- =============================================================
21 There's a lot in GHCbase. It's set out as follows:
23 * Classes (CCallable, CReturnable, ...)
25 * Types and their instances
27 * ST, PrimIO, and IO monads
35 * Other support functions
37 ============================================================= -}
39 {- =============================================================
46 {- =============================================================
47 ** TYPES and their instances
49 data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension
50 instance CCallable Addr
51 instance CReturnable Addr
53 ---------------------------------------------------------------
54 data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension
55 instance CCallable Word
56 instance CReturnable Word
58 ---------------------------------------------------------------
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
67 instance Eq PackedString where
68 x == y = compare x y == EQ
69 x /= y = compare x y /= EQ
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 }
80 --instance Read PackedString: ToDo
82 instance Show PackedString where
83 showsPrec p ps r = showsPrec p (GHCps.unpackPS ps) r
84 showList = showList__ (showsPrec 0)
86 ---------------------------------------------------------------
87 data State a = S# (State# a)
88 data ForeignObj = ForeignObj ForeignObj#
89 #ifndef __PARALLEL_HASKELL__
90 data StablePtr a = StablePtr (StablePtr# a)
93 instance CCallable (StablePtr a)
94 instance CCallable ForeignObj
95 instance CReturnable (StablePtr a)
97 #ifndef __PARALLEL_HASKELL__
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.
103 makeStablePtr :: a -> PrimIO (StablePtr a)
104 deRefStablePtr :: StablePtr a -> PrimIO a
105 freeStablePtr :: StablePtr a -> PrimIO ()
107 eqForeignObj :: ForeignObj -> ForeignObj -> Bool
108 makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj
109 performGC :: PrimIO ()
111 {-# INLINE deRefStablePtr #-}
112 {-# INLINE freeStablePtr #-}
113 {-# INLINE performGC #-}
115 makeStablePtr f = ST $ \ (S# rw1#) ->
116 case makeStablePtr# f rw1# of
117 StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#)
119 deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) ->
120 case deRefStablePtr# sp# rw1# of
121 StateAndPtr# rw2# a -> (a, S# rw2#)
123 freeStablePtr sp = _ccall_ freeStablePointer sp
125 makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) ->
126 case makeForeignObj# obj finaliser s# of
127 StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#)
130 = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
132 instance Eq ForeignObj where
133 p == q = eqForeignObj p q
134 p /= q = not (eqForeignObj p q)
136 performGC = _ccall_GC_ StgPerformGarbageCollection
138 #endif /* !__PARALLEL_HASKELL__ */
140 ---------------------------------------------------------------
141 data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray#
142 data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
144 data StateAndPtr# s elt = StateAndPtr# (State# s) elt
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#
153 #ifndef __PARALLEL_HASKELL__
154 data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
156 data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj#
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)
163 data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
165 ---------------------------------------------------------------
167 {-# GENERATE_SPECS data a :: Lift a #-}
169 {- =============================================================
170 ** ST, PrimIO, and IO monads
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.
178 newtype ST s a = ST (State s -> (a, State s))
181 = case m (S# realWorld#) of
184 instance Monad (ST s) where
185 {-# INLINE return #-}
188 return x = ST $ \ s -> (x, s)
189 m >> k = m >>= \ _ -> k
193 case (m s) of {(r, new_s) ->
194 case (k r) of { ST k2 ->
197 {-# INLINE returnST #-}
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
208 -- not sure whether to 1.3-ize these or what...
209 {-# INLINE returnStrictlyST #-}
210 {-# INLINE thenStrictlyST #-}
211 {-# INLINE seqStrictlyST #-}
213 {-# GENERATE_SPECS returnStrictlyST a #-}
214 returnStrictlyST :: a -> ST s a
216 {-# GENERATE_SPECS thenStrictlyST a b #-}
217 thenStrictlyST :: ST s a -> (a -> ST s b) -> ST s b
219 {-# GENERATE_SPECS seqStrictlyST a b #-}
220 seqStrictlyST :: ST s a -> ST s b -> ST s b
222 returnStrictlyST a = ST $ \ s@(S# _) -> (a, s)
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 ->
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) ->
233 -- BUILT-IN: runST (see Builtin.hs)
235 unsafeInterleaveST :: ST s a -> ST s a -- ToDo: put in state-interface.tex
236 unsafeInterleaveST (ST m) = ST $ \ s ->
242 fixST :: (a -> ST s a) -> ST s a
243 fixST k = ST $ \ s ->
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])
257 mapAndUnzipST = Monad.mapAndUnzipL
259 forkST :: ST s a -> ST s a
261 #ifndef __CONCURRENT_HASKELL__
265 forkST (ST action) = ST $ \ s ->
267 (r, new_s) = action s
269 new_s `_fork_` (r, s)
271 _fork_ x y = case (fork# x) of { 0# -> parError#; _ -> y }
273 #endif {- concurrent -}
275 ----------------------------------------------------------------------------
276 type PrimIO a = ST RealWorld a
278 fixPrimIO :: (a -> PrimIO a) -> PrimIO a
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
286 primIOToIO = stToIO -- for backwards compatibility
289 stToIO (ST m) = IO $ ST $ \ s ->
290 case (m s) of { (r, new_s) ->
293 ioToST (IO (ST io)) = ST $ \ s ->
294 case (io s) of { (r, new_s) ->
296 Right a -> (a, new_s)
297 Left e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
300 {-# GENERATE_SPECS unsafePerformPrimIO a #-}
301 unsafePerformPrimIO :: PrimIO a -> a
302 unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
303 forkPrimIO :: PrimIO a -> PrimIO a
305 unsafePerformPrimIO = runST
306 unsafeInterleavePrimIO = unsafeInterleaveST
309 -- the following functions are now there for backward compatibility mostly:
311 {-# GENERATE_SPECS returnPrimIO a #-}
312 returnPrimIO :: a -> PrimIO a
314 {-# GENERATE_SPECS thenPrimIO b #-}
315 thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
317 {-# GENERATE_SPECS seqPrimIO b #-}
318 seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b
320 listPrimIO :: [PrimIO a] -> PrimIO [a]
321 mapPrimIO :: (a -> PrimIO b) -> [a] -> PrimIO [b]
322 mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c])
324 {-# INLINE returnPrimIO #-}
325 {-# INLINE thenPrimIO #-}
326 {-# INLINE seqPrimIO #-}
328 returnPrimIO = return
331 listPrimIO = accumulate
333 mapAndUnzipPrimIO = Monad.mapAndUnzipL
335 ---------------------------------------------------------
336 newtype IO a = IO (PrimIO (Either GHCio.IOError a))
338 instance Functor IO where
339 map f x = x >>= (return . f)
341 instance Monad IO where
342 {-# INLINE return #-}
345 m >> k = m >>= \ _ -> k
346 return x = IO $ ST $ \ s@(S# _) -> (Right x, s)
350 let (r, new_s) = m s in
352 Left err -> (Left err, new_s)
353 Right x -> case (k x) of { IO (ST k2) ->
356 instance Show (IO a) where
357 showsPrec p f = showString "<<IO action>>"
358 showList = showList__ (showsPrec 0)
360 fixIO :: (a -> IO a) -> IO a
361 -- not required but worth having around
363 fixIO k = IO $ ST $ \ s ->
365 (IO (ST k_loop)) = k loop
367 (Right loop, _) = result
371 {- =============================================================
372 ** BASIC ARRAY (and ByteArray) SUPPORT
375 type IPr = (Int, Int)
377 data Ix ix => Array ix elt = Array (ix,ix) (Array# elt)
378 data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray#
380 instance CCallable (ByteArray ix)
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'
386 instance (Ix a, Ord b) => Ord (Array a b) where
387 compare a b = compare (assocs a) (assocs b)
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 ' ' .
394 showList = showList__ (showsPrec 0)
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,
401 readList = readList__ (readsPrec 0)
403 -----------------------------------------------------------------
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).
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.
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)
423 instance CCallable (MutableByteArray s ix)
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)
429 {-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt),
430 (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt)
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) #-}
438 newArray ixs@(ix_start, ix_end) init = ST $ \ (S# s#) ->
439 let n# = case (if null (range ixs)
441 else (index ixs ix_end) + 1) of { I# x -> x }
442 -- size is one bigger than index of last elem
444 case (newArray# n# init s#) of { StateAndMutableArray# s2# arr# ->
445 (MutableArray ixs arr#, S# s2#)}
447 newCharArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
448 let n# = case (if null (range ixs)
450 else ((index ixs ix_end) + 1)) of { I# x -> x }
452 case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
453 (MutableByteArray ixs barr#, S# s2#)}
455 newIntArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
456 let n# = case (if null (range ixs)
458 else ((index ixs ix_end) + 1)) of { I# x -> x }
460 case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
461 (MutableByteArray ixs barr#, S# s2#)}
463 newAddrArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
464 let n# = case (if null (range ixs)
466 else ((index ixs ix_end) + 1)) of { I# x -> x }
468 case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
469 (MutableByteArray ixs barr#, S# s2#)}
471 newFloatArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
472 let n# = case (if null (range ixs)
474 else ((index ixs ix_end) + 1)) of { I# x -> x }
476 case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
477 (MutableByteArray ixs barr#, S# s2#)}
479 newDoubleArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) ->
480 let n# = case (if null (range ixs)
482 else ((index ixs ix_end) + 1)) of { I# x -> x }
484 case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
485 (MutableByteArray ixs barr#, S# s2#)}
487 boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix)
488 boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
490 {-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-}
491 {-# SPECIALIZE boundsOfByteArray :: MutableByteArray s Int -> IPr #-}
493 boundsOfArray (MutableArray ixs _) = ixs
494 boundsOfByteArray (MutableByteArray ixs _) = ixs
496 readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
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
504 {-# SPECIALIZE readArray :: MutableArray s Int elt -> Int -> ST s elt,
505 MutableArray s IPr elt -> IPr -> ST s elt
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 #-}
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 ->
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# ->
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# ->
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# ->
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# ->
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# ->
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
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 #-}
556 indexCharArray (ByteArray ixs barr#) n
557 = case (index ixs n) of { I# n# ->
558 case indexCharArray# barr# n# of { r# ->
561 indexIntArray (ByteArray ixs barr#) n
562 = case (index ixs n) of { I# n# ->
563 case indexIntArray# barr# n# of { r# ->
566 indexAddrArray (ByteArray ixs barr#) n
567 = case (index ixs n) of { I# n# ->
568 case indexAddrArray# barr# n# of { r# ->
571 indexFloatArray (ByteArray ixs barr#) n
572 = case (index ixs n) of { I# n# ->
573 case indexFloatArray# barr# n# of { r# ->
576 indexDoubleArray (ByteArray ixs barr#) n
577 = case (index ixs n) of { I# n# ->
578 case indexDoubleArray# barr# n# of { r# ->
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
588 indexCharOffAddr (A# addr#) n
589 = case n of { I# n# ->
590 case indexCharOffAddr# addr# n# of { r# ->
593 indexIntOffAddr (A# addr#) n
594 = case n of { I# n# ->
595 case indexIntOffAddr# addr# n# of { r# ->
598 indexAddrOffAddr (A# addr#) n
599 = case n of { I# n# ->
600 case indexAddrOffAddr# addr# n# of { r# ->
603 indexFloatOffAddr (A# addr#) n
604 = case n of { I# n# ->
605 case indexFloatOffAddr# addr# n# of { r# ->
608 indexDoubleOffAddr (A# addr#) n
609 = case n of { I# n# ->
610 case indexDoubleOffAddr# addr# n# of { r# ->
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 ()
620 {-# SPECIALIZE writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (),
621 MutableArray s IPr elt -> IPr -> elt -> ST s ()
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 () #-}
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# ->
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# ->
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# ->
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# ->
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# ->
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# ->
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)
666 {-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt),
667 MutableArray s IPr elt -> ST s (Array IPr elt)
669 {-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
671 freezeArray (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
672 let n# = case (if null (range ixs)
674 else (index ixs ix_end) + 1) of { I# x -> x }
676 case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
677 (Array ixs frozen#, S# s2#)}
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
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#
690 init = error "freezeArray: element not copied"
693 -> MutableArray# s ele -> MutableArray# s ele
695 -> StateAndMutableArray# s ele
697 copy cur# end# from# to# s#
699 = StateAndMutableArray# s# to#
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#
706 freezeCharArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
707 let n# = case (if null (range ixs)
709 else ((index ixs ix_end) + 1)) of { I# x -> x }
711 case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
712 (ByteArray ixs frozen#, S# s2#) }
714 freeze :: MutableByteArray# s -- the thing
715 -> Int# -- size of thing to be frozen
716 -> State# s -- the Universe and everything
717 -> StateAndByteArray# 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#
726 -> MutableByteArray# s -> MutableByteArray# s
728 -> StateAndMutableByteArray# s
730 copy cur# end# from# to# s#
732 = StateAndMutableByteArray# s# to#
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#
739 freezeIntArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
740 let n# = case (if null (range ixs)
742 else ((index ixs ix_end) + 1)) of { I# x -> x }
744 case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
745 (ByteArray ixs frozen#, S# s2#) }
747 freeze :: MutableByteArray# s -- the thing
748 -> Int# -- size of thing to be frozen
749 -> State# s -- the Universe and everything
750 -> StateAndByteArray# 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#
759 -> MutableByteArray# s -> MutableByteArray# s
761 -> StateAndMutableByteArray# s
763 copy cur# end# from# to# s#
765 = StateAndMutableByteArray# s# to#
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#
772 freezeAddrArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
773 let n# = case (if null (range ixs)
775 else ((index ixs ix_end) + 1)) of { I# x -> x }
777 case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
778 (ByteArray ixs frozen#, S# s2#) }
780 freeze :: MutableByteArray# s -- the thing
781 -> Int# -- size of thing to be frozen
782 -> State# s -- the Universe and everything
783 -> StateAndByteArray# 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#
792 -> MutableByteArray# s -> MutableByteArray# s
794 -> StateAndMutableByteArray# s
796 copy cur# end# from# to# s#
798 = StateAndMutableByteArray# s# to#
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#
805 freezeFloatArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
806 let n# = case (if null (range ixs)
808 else ((index ixs ix_end) + 1)) of { I# x -> x }
810 case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
811 (ByteArray ixs frozen#, S# s2#) }
813 freeze :: MutableByteArray# s -- the thing
814 -> Int# -- size of thing to be frozen
815 -> State# s -- the Universe and everything
816 -> StateAndByteArray# 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#
825 -> MutableByteArray# s -> MutableByteArray# s
827 -> StateAndMutableByteArray# s
829 copy cur# end# from# to# s#
831 = StateAndMutableByteArray# s# to#
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#
838 freezeDoubleArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
839 let n# = case (if null (range ixs)
841 else ((index ixs ix_end) + 1)) of { I# x -> x }
843 case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
844 (ByteArray ixs frozen#, S# s2#) }
846 freeze :: MutableByteArray# s -- the thing
847 -> Int# -- size of thing to be frozen
848 -> State# s -- the Universe and everything
849 -> StateAndByteArray# 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#
858 -> MutableByteArray# s -> MutableByteArray# s
860 -> StateAndMutableByteArray# s
862 copy cur# end# from# to# s#
864 = StateAndMutableByteArray# s# to#
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#
871 unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
872 unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
874 {-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int)
877 unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) ->
878 case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
879 (Array ixs frozen#, S# s2#) }
881 unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
882 case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
883 (ByteArray ixs frozen#, S# s2#) }
886 --This takes a immutable array, and copies it into a mutable array, in a
889 {-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt),
890 Array IPr elt -> ST s (MutableArray s IPr elt)
893 thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
894 let n# = case (if null (range ixs)
896 else (index ixs ix_end) + 1) of { I# x -> x }
898 case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
899 (MutableArray ixs thawed#, S# s2#)}
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
907 = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# ->
908 copy 0# n# arr# newarr1# s2# }
910 init = error "thawArray: element not copied"
914 -> MutableArray# s ele
916 -> StateAndMutableArray# s ele
918 copy cur# end# from# to# s#
920 = StateAndMutableArray# s# to#
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#
927 sameMutableArray :: MutableArray s ix elt -> MutableArray s ix elt -> Bool
928 sameMutableByteArray :: MutableByteArray s ix -> MutableByteArray s ix -> Bool
930 sameMutableArray (MutableArray _ arr1#) (MutableArray _ arr2#)
931 = sameMutableArray# arr1# arr2#
933 sameMutableByteArray (MutableByteArray _ arr1#) (MutableByteArray _ arr2#)
934 = sameMutableByteArray# arr1# arr2#
936 {- =============================================================
937 ** VARIABLES, including MVars and IVars
940 --************************************************************************
943 type MutableVar s a = MutableArray s Int a
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
950 newVar init = ST $ \ (S# s#) ->
951 case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
952 (MutableArray vAR_IXS arr#, S# s2#) }
954 vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n"
956 readVar (MutableArray _ var#) = ST $ \ (S# s#) ->
957 case readArray# var# 0# s# of { StateAndPtr# s2# r ->
960 writeVar (MutableArray _ var#) val = ST $ \ (S# s#) ->
961 case writeArray# var# 0# val s# of { s2# ->
964 sameVar (MutableArray _ var1#) (MutableArray _ var2#)
965 = sameMutableArray# var1# var2#
967 --%************************************************************************
969 --\subsection[PreludeGlaST-mvars]{M-Structures}
971 --%************************************************************************
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
982 data MVar a = MVar (SynchVar# RealWorld a)
984 newEmptyMVar :: IO (MVar a)
986 newEmptyMVar = IO $ ST $ \ (S# s#) ->
987 case newSynchVar# s# of
988 StateAndSynchVar# s2# svar# -> (Right (MVar svar#), S# s2#)
990 takeMVar :: MVar a -> IO a
992 takeMVar (MVar mvar#) = IO $ ST $ \ (S# s#) ->
993 case takeMVar# mvar# s# of
994 StateAndPtr# s2# r -> (Right r, S# s2#)
996 putMVar :: MVar a -> a -> IO ()
998 putMVar (MVar mvar#) x = IO $ ST $ \ (S# s#) ->
999 case putMVar# mvar# x s# of
1000 s2# -> (Right (), S# s2#)
1002 newMVar :: a -> IO (MVar a)
1005 newEmptyMVar >>= \ mvar ->
1006 putMVar mvar value >>
1009 readMVar :: MVar a -> IO a
1012 takeMVar mvar >>= \ value ->
1013 putMVar mvar value >>
1016 swapMVar :: MVar a -> a -> IO a
1019 takeMVar mvar >>= \ old ->
1023 --%************************************************************************
1025 --\subsection[PreludeGlaST-ivars]{I-Structures}
1027 --%************************************************************************
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.
1034 data IVar a = IVar (SynchVar# RealWorld a)
1036 newIVar :: IO (IVar a)
1038 newIVar = IO $ ST $ \ (S# s#) ->
1039 case newSynchVar# s# of
1040 StateAndSynchVar# s2# svar# -> (Right (IVar svar#), S# s2#)
1042 readIVar :: IVar a -> IO a
1044 readIVar (IVar ivar#) = IO $ ST $ \ (S# s#) ->
1045 case readIVar# ivar# s# of
1046 StateAndPtr# s2# r -> (Right r, S# s2#)
1048 writeIVar :: IVar a -> a -> IO ()
1050 writeIVar (IVar ivar#) x = IO $ ST $ \ (S# s#) ->
1051 case writeIVar# ivar# x s# of
1052 s2# -> (Right (), S# s2#)
1054 {- =============================================================
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.)
1067 @threadWait@ delays rescheduling of a thread until input on the
1068 specified file descriptor is available for reading (just like select).
1071 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
1073 threadDelay (I# x#) = IO $ ST $ \ (S# s#) ->
1074 case delay# x# s# of
1075 s2# -> (Right (), S# s2#)
1077 threadWaitRead (I# x#) = IO $ ST $ \ (S# s#) ->
1078 case waitRead# x# s# of
1079 s2# -> (Right (), S# s2#)
1081 threadWaitWrite (I# x#) = IO $ ST $ \ (S# s#) ->
1082 case waitWrite# x# s# of
1083 s2# -> (Right (), S# s2#)
1085 {- =============================================================
1086 ** OTHER SUPPORT FUNCTIONS
1088 3 flavors, basically: string support, error/trace-ish, and read/show-ish.
1090 seq, par, fork :: Eval a => a -> b -> b
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 }
1100 ---------------------------------------------------------------
1101 -- HACK: Magic unfoldings not implemented for unboxed lists
1102 -- Need to define a "build" to avoid undefined symbol
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 (:) []
1111 ---------------------------------------------------------------
1112 -- string-support functions:
1113 ---------------------------------------------------------------
1115 --------------------------------------------------------------------------
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?
1123 packStringForC__ str = case (GHCps.packString str) of { PS bytes _ _ -> bytes}
1125 unpackPS__ addr -- calls injected by compiler
1129 | ch `eqChar#` '\0'# = []
1130 | True = C# ch : unpack (nh +# 1#)
1132 ch = indexCharOffAddr# addr nh
1134 unpackAppendPS__ addr rest
1138 | ch `eqChar#` '\0'# = rest
1139 | True = C# ch : unpack (nh +# 1#)
1141 ch = indexCharOffAddr# addr nh
1143 unpackFoldrPS__ addr f z
1147 | ch `eqChar#` '\0'# = z
1148 | True = C# ch `f` unpack (nh +# 1#)
1150 ch = indexCharOffAddr# addr nh
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))
1156 ---------------------------------------------------------------
1157 -- injected literals:
1158 ---------------------------------------------------------------
1159 integer_0, integer_1, integer_2, integer_m1 :: Integer
1161 integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
1163 ---------------------------------------------------------------
1164 -- error/trace-ish functions:
1165 ---------------------------------------------------------------
1167 errorIO :: PrimIO () -> a
1170 = case (errorIO# io) of
1173 bottom = bottom -- Never evaluated
1175 error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
1178 #ifdef __PARALLEL_HASKELL__
1179 = errorIO (msg_hdr sTDERR{-msg hdr-} >>
1180 _ccall_ fflush sTDERR >>
1182 _ccall_ fflush sTDERR >>
1183 _ccall_ stg_exit (1::Int)
1186 = errorIO (msg_hdr sTDERR{-msg hdr-} >>
1187 _ccall_ fflush sTDERR >>
1189 _ccall_ fflush sTDERR >>
1190 _ccall_ getErrorHandler >>= \ errorHandler ->
1191 if errorHandler == (-1::Int) then
1192 _ccall_ stg_exit (1::Int)
1194 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
1196 _ccall_ decrementErrorCount >>= \ () ->
1197 deRefStablePtr osptr >>= \ oact ->
1200 #endif {- !parallel -}
1202 sTDERR = (``stderr'' :: Addr)
1206 fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
1208 fputs stream [] = return True
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)
1214 ---------------------------------------------------------------
1215 -- Used for compiler-generated error message;
1216 -- encoding saves bytes of string junk.
1218 absentErr, parError :: a
1220 , noDefaultMethodError
1221 , noExplicitMethodError
1222 , nonExhaustiveGuardsError
1225 , recUpdError :: String -> a
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"
1230 irrefutPatError s = error ("irrefutPatError:"++s)
1231 noDefaultMethodError s = error ("noDefaultMethodError:"++s)
1232 noExplicitMethodError s = error ("noExplicitMethodError:"++s)
1233 nonExhaustiveGuardsError s = error ("nonExhaustiveGuardsError:"++s)
1236 = error__ (\ x -> _ccall_ PatErrorHdrHook x) ("Pattern-matching failed in: "++msg++"\n")
1237 recConError s = error ("recConError:"++s)
1238 recUpdError s = error ("recUpdError:"++s)
1240 ---------------------------------------------------------------
1241 -- ******** defn of `_trace' using Glasgow IO *******
1243 {-# GENERATE_SPECS _trace a #-}
1245 trace :: String -> a -> a
1248 = unsafePerformPrimIO (
1249 ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ()) >>
1250 fputs sTDERR string >>
1251 ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
1254 sTDERR = (``stderr'' :: Addr)
1256 ---------------------------------------------------------------
1257 -- read/show-ish functions:
1258 ---------------------------------------------------------------
1259 {-# GENERATE_SPECS readList__ a #-}
1260 readList__ :: ReadS a -> ReadS [a]
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,
1267 readl2 s = [([],t) | ("]",t) <- lex s] ++
1268 [(x:xs,v) | (",",t) <- lex s,
1272 {-# GENERATE_SPECS showList__ a #-}
1273 showList__ :: (a -> ShowS) -> [a] -> ShowS
1275 showList__ showx [] = showString "[]"
1276 showList__ showx (x:xs) = showChar '[' . showx x . showl xs
1278 showl [] = showChar ']'
1279 showl (x:xs) = showString ", " . showx x . showl xs
1282 showSpace = {-showChar ' '-} \ xs -> ' ' : xs
1284 -- ******************************************************************
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
1294 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1295 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1297 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1299 lexString ('"':s) = [("\"",s)]
1300 lexString s = [(ch++str, u)
1301 | (ch,t) <- lexStrItem s,
1302 (str,u) <- lexString t ]
1304 lexStrItem ('\\':'&':s) = [("\\&",s)]
1305 lexStrItem ('\\':c:s) | isSpace c
1306 = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
1307 lexStrItem s = lexLitChar s
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
1316 isSingle c = c `elem` ",;()[]{}_`"
1317 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1318 isIdChar c = isAlphanum c || c `elem` "_'"
1320 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1322 lexFracExp s = [("",s)]
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]
1330 lexDigits :: ReadS String
1331 lexDigits = nonnull isDigit
1333 nonnull :: (Char -> Bool) -> ReadS String
1334 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1336 lexLitChar :: ReadS String
1337 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1339 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
1340 lexEsc s@(d:_) | isDigit d = lexDigits s
1342 lexLitChar (c:s) = [([c],s)]
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)
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",
1357 readLitChar :: ReadS Char
1359 readLitChar ('\\':s) = readEsc s
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]]
1384 readLitChar (c:s) = [(c,s)]
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)
1401 protectEsc p f = f . cont
1402 where cont s@(c:_) | p c = "\\&" ++ s
1405 -- ******************************************************************
1407 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
1408 readDec :: (Integral a) => ReadS a
1409 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
1411 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
1412 readOct :: (Integral a) => ReadS a
1413 readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
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)
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 ]
1428 = case quotRem n 10 of { (n', d) ->
1429 case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
1433 if n' == 0 then r' else showInt n' r'
1436 -- ******************************************************************
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,
1444 read'' r = [(n,s) | (str,s) <- lex r,
1445 (n,"") <- readPos str]
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))
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
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
1466 -- ******************************************************************
1468 itos# :: Int# -> String
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#)) []
1475 '-':itos' (negateInt# n) []
1479 itos' :: Int# -> String -> String
1481 if n `ltInt#` 10# then
1482 C# (chr# (n `plusInt#` ord# '0'#)) : cs
1484 itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs)
1486 itos :: Int -> String
1487 itos (I# n) = itos# n
1489 jtos :: Integer -> String
1496 jtos' :: Integer -> String -> String
1499 chr (fromInteger (n + ord_0)) : cs
1501 jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs)
1503 chr = (toEnum :: Int -> Char)
1504 ord = (fromEnum :: Char -> Int)
1507 ord_0 = fromInt (ord '0')
1509 -- ******************************************************************
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.
1516 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
1517 readFloat :: (RealFloat a) => ReadS a
1518 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
1520 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
1523 = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
1525 where readFix r = [(read (ds++ds'), length ds', t)
1526 | (ds,'.':s) <- lexDigits r,
1527 (ds',t) <- lexDigits s ]
1529 readExp (e:s) | e `elem` "eE" = readExp' s
1532 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1533 readExp' ('+':s) = readDec s
1534 readExp' s = readDec s
1536 readRational__ :: String -> Rational -- we export this one (non-std)
1537 -- NB: *does* handle a leading "-"
1538 readRational__ top_s
1540 '-' : xs -> - (read_me xs)
1544 = case [x | (x,t) <- readRational s, ("","") <- lex t] of
1546 [] -> error ("readRational__: no parse:" ++ top_s)
1547 _ -> error ("readRational__: ambiguous parse:" ++ top_s)
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),
1557 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
1558 showFloat:: (RealFloat a) => a -> ShowS
1560 if x == 0 then showString ("0." ++ take (m-1) zeros)
1561 else if e >= m-1 || e < 0 then showSci else showFix
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' )
1571 ((fromInt w * log (fromInteger b)) / log 10 :: Double)
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)
1577 t = s%1 * (b%1)^^n * 10^^(m'-e1-1)
1578 e1 = floor (logBase 10 x)
1579 (s, n) = decodeFloat x
1583 ---------------------------------------------------------
1584 -- definitions of the boxed PrimOps; these will be
1585 -- used in the case of partial applications, etc.
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
1600 -- definitions of the boxed PrimOps; these will be
1601 -- used in the case of partial applications, etc.
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)
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
1616 float2Int (F# x) = I# (float2Int# x)
1617 int2Float (I# x) = F# (int2Float# x)
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)
1632 powerFloat (F# x) (F# y) = F# (powerFloat# x y)
1634 -- definitions of the boxed PrimOps; these will be
1635 -- used in the case of partial applications, etc.
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)
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
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)
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)
1668 powerDouble (D# x) (D# y) = D# (powerDouble# x y)
1670 ---------------------------------------------------------
1672 [In response to a request by simonpj, Joe Fasel writes:]
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.
1687 {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
1688 fromRational__ :: (RealFloat a) => Rational -> a
1689 fromRational__ x = x'
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.
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
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
1710 (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
1711 / fromInteger (denominator x))
1713 -------------------------------------------------------------------------
1714 -- from/by Lennart, 94/09/26
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
1723 let (r', e) = normalize r
1726 startExpExp = 4 :: Int
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)
1733 norm startExpExp r 0
1734 where norm :: Int -> Rational -> Int -> (Rational, Int)
1735 -- Invariant: r*10^e == original r
1740 in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
1743 drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
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)
1749 let s = show ((round (r * 10^n))::Integer)
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
1756 head s : "."++ drop0 (tail s) ++ "e" ++ show e0