diff options
Diffstat (limited to 'ghc/lib/std')
31 files changed, 2172 insertions, 903 deletions
diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs index e703494642..5ff36c9748 100644 --- a/ghc/lib/std/Array.lhs +++ b/ghc/lib/std/Array.lhs @@ -63,33 +63,15 @@ infixl 9 !, // \begin{code} -#ifdef USE_FOLDR_BUILD -{-# INLINE indices #-} -{-# INLINE elems #-} -{-# INLINE assocs #-} -#endif {-# SPECIALISE listArray :: (Int,Int) -> [b] -> Array Int b #-} listArray :: (Ix a) => (a,a) -> [b] -> Array a b listArray b vs = array b (zip (range b) vs) -{-# SPECIALISE indices :: Array Int b -> [Int] #-} -indices :: (Ix a) => Array a b -> [a] -indices = range . bounds - -{-# SPECIALISE elems :: Array Int b -> [b] #-} +{-# INLINE elems #-} elems :: (Ix a) => Array a b -> [b] elems a = [a!i | i <- indices a] -{-# SPECIALISE assocs :: Array Int b -> [(Int,b)] #-} -assocs :: (Ix a) => Array a b -> [(a,b)] -assocs a = [(i, a!i) | i <- indices a] - -{-# SPECIALISE amap :: (b -> c) -> Array Int b -> Array Int c #-} -amap :: (Ix a) => (b -> c) -> Array a b -> Array a c -amap f a = array b [(i, f (a!i)) | i <- range b] - where b = bounds a - ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c ixmap b f a = array b [(i, a ! f i) | i <- range b] \end{code} @@ -101,34 +83,6 @@ ixmap b f a = array b [(i, a ! f i) | i <- range b] %* * %********************************************************* -\begin{code} -instance Ix a => Functor (Array a) where - fmap = amap - -instance (Ix a, Eq b) => Eq (Array a b) where - a == a' = assocs a == assocs a' - a /= a' = assocs a /= assocs a' - -instance (Ix a, Ord b) => Ord (Array a b) where - compare a b = compare (assocs a) (assocs b) - -instance (Ix a, Show a, Show b) => Show (Array a b) where - showsPrec p a = showParen (p > 9) ( - showString "array " . - shows (bounds a) . showChar ' ' . - shows (assocs a) ) - showList = showList__ (showsPrec 0) - -{- -instance (Ix a, Read a, Read b) => Read (Array a b) where - readsPrec p = readParen (p > 9) - (\r -> [(array b as, u) | ("array",s) <- lex r, - (b,t) <- reads s, - (as,u) <- reads t ]) - readList = readList__ (readsPrec 0) --} -\end{code} - #else \begin{code} diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index e808b2a0d5..9d7e6a7c79 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -4,7 +4,7 @@ \section[CPUTime]{Haskell 1.4 CPU Time Library} \begin{code} -{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} +{-# OPTIONS -#include "cbits/stgio.h" #-} module CPUTime ( @@ -17,15 +17,13 @@ module CPUTime #ifndef __HUGS__ \begin{code} -import PrelBase -import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray ) -import PrelMaybe -import PrelNum -import PrelNumExtra -import PrelIOBase -import PrelST -import IO ( ioError ) -import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt +import Prelude -- To generate the dependency +import PrelGHC ( indexIntArray# ) +import PrelBase ( Int(..) ) +import PrelByteArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray ) +import PrelNum ( fromInt ) +import PrelIOBase ( IOError(..), IOErrorType( UnsupportedOperation ), + unsafePerformIO, stToIO ) import Ratio \end{code} diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index 81331191f7..6ca00295fd 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -53,14 +53,20 @@ module Directory #ifdef __HUGS__ --import PreludeBuiltin #else -import PrelBase -import PrelIOBase -import PrelHandle -import PrelST -import PrelArr + +import Prelude -- Just to get it in the dependencies + +import PrelGHC ( RealWorld, int2Word#, or#, and# ) +import PrelByteArr ( ByteArray, MutableByteArray, + newWordArray, readWordArray, newCharArray, + unsafeFreezeByteArray + ) import PrelPack ( unpackNBytesST, packString, unpackCStringST ) -import PrelAddr +import PrelIOBase ( stToIO, + constructErrorAndFail, constructErrorAndFailWithInfo, + IOError(IOError), IOErrorType(SystemError) ) import Time ( ClockTime(..) ) +import PrelAddr ( Addr, nullAddr, Word(..), wordToInt ) #endif \end{code} diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index f72b817545..1a8d4b338c 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -107,7 +107,7 @@ import PrelRead ( readParen, Read(..), reads, lex, import PrelShow import PrelMaybe ( Either(..), Maybe(..) ) import PrelAddr ( Addr(..), nullAddr ) -import PrelArr ( ByteArray ) +import PrelByteArr ( ByteArray ) import PrelPack ( unpackNBytesAccST ) import PrelException ( ioError, catch ) diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs index e7ee2042f7..ab733ee3ee 100644 --- a/ghc/lib/std/Ix.lhs +++ b/ghc/lib/std/Ix.lhs @@ -37,6 +37,8 @@ import PrelList( null ) import PrelEnum import PrelShow import PrelNum + +default() \end{code} %********************************************************* diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs index fa56105a82..ac2a037402 100644 --- a/ghc/lib/std/Numeric.lhs +++ b/ghc/lib/std/Numeric.lhs @@ -8,7 +8,6 @@ Odds and ends, mostly functions for reading and showing \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} module Numeric ( fromRat -- :: (RealFloat a) => Rational -> a @@ -34,23 +33,27 @@ module Numeric -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +import Char + #ifndef __HUGS__ -import PrelBase -import PrelMaybe -import PrelShow -import PrelArr -import PrelNum -import PrelNumExtra -import PrelRead -import PrelErr ( error ) + -- GHC imports +import Prelude -- For dependencies +import PrelBase ( Char(..) ) +import PrelRead -- Lots of things +import PrelReal ( showSigned ) +import PrelFloat ( fromRat, FFFormat(..), + formatRealFloat, floatToDigits, showFloat + ) +import PrelNum ( ord_0 ) #else -import Char + -- Hugs imports import Array #endif -\end{code} #ifndef __HUGS__ +\end{code} + \begin{code} showInt :: Integral a => a -> ShowS showInt i rs @@ -82,7 +85,15 @@ showGFloat d x = showString (formatRealFloat FFGeneric d x) \end{code} -#else +#else + +%********************************************************* +%* * + All of this code is for Hugs only + GHC gets it from PrelFloat! +%* * +%********************************************************* + \begin{code} -- This converts a rational to a floating. This should be used in the -- Fractional instances of Float and Double. diff --git a/ghc/lib/std/PrelAddr.lhs b/ghc/lib/std/PrelAddr.lhs index 70f4a7c068..1f61cec4ad 100644 --- a/ghc/lib/std/PrelAddr.lhs +++ b/ghc/lib/std/PrelAddr.lhs @@ -22,7 +22,6 @@ module PrelAddr ( import PrelGHC import PrelBase -import PrelCCall \end{code} \begin{code} diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index e1d1f2b7ce..03873d6165 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -6,6 +6,8 @@ Array implementation, @PrelArr@ exports the basic array types and operations. +For byte-arrays see @PrelByteArr@. + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} @@ -16,11 +18,13 @@ import Ix import PrelList (foldl) import PrelST import PrelBase -import PrelCCall import PrelAddr import PrelGHC +import PrelShow infixl 9 !, // + +default () \end{code} \begin{code} @@ -30,9 +34,6 @@ array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b {-# SPECIALISE (!) :: Array Int b -> Int -> b #-} (!) :: (Ix a) => Array a b -> a -> b -{-# SPECIALISE bounds :: Array Int b -> (Int,Int) #-} -bounds :: (Ix a) => Array a b -> (a,a) - {-# SPECIALISE (//) :: Array Int b -> [(Int,b)] -> Array Int b #-} (//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b @@ -41,6 +42,10 @@ accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b {-# SPECIALISE accumArray :: (b -> c -> b) -> b -> (Int,Int) -> [(Int,c)] -> Array Int b #-} accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b + +bounds :: (Ix a) => Array a b -> (a,a) +assocs :: (Ix a) => Array a b -> [(a,b)] +indices :: (Ix a) => Array a b -> [a] \end{code} @@ -54,12 +59,8 @@ accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a type IPr = (Int, Int) data Ix ix => Array ix elt = Array ix ix (Array# elt) -data Ix ix => ByteArray ix = ByteArray ix ix ByteArray# data Ix ix => MutableArray s ix elt = MutableArray ix ix (MutableArray# s elt) -data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) -instance CCallable (MutableByteArray s ix) -instance CCallable (ByteArray ix) data MutableVar s a = MutableVar (MutVar# s a) @@ -71,10 +72,6 @@ instance Eq (MutableVar s a) where instance Eq (MutableArray s ix elt) where MutableArray _ _ arr1# == MutableArray _ _ arr2# = sameMutableArray# arr1# arr2# - -instance Eq (MutableByteArray s ix) where - MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2# - = sameMutableByteArray# arr1# arr2# \end{code} %********************************************************* @@ -108,8 +105,20 @@ writeVar (MutableVar var#) val = ST $ \ s# -> "array", "!" and "bounds" are basic; the rest can be defined in terms of them \begin{code} +{-# INLINE bounds #-} bounds (Array l u _) = (l,u) +{-# INLINE assocs #-} -- Want to fuse the list comprehension +assocs a = [(i, a!i) | i <- indices a] + +{-# INLINE indices #-} +indices = range . bounds + +{-# SPECIALISE amap :: (b -> c) -> Array Int b -> Array Int c #-} +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +amap f a = array b [(i, f (a!i)) | i <- range b] + where b = bounds a + (Array l u arr#) ! i = let n# = case (index (l,u) i) of { I# x -> x } -- index fails if out of range in @@ -197,6 +206,42 @@ accumArray f zero ixs ivs %********************************************************* %* * +\subsection{Array instances} +%* * +%********************************************************* + + +\begin{code} +instance Ix a => Functor (Array a) where + fmap = amap + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + a /= a' = assocs a /= assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + compare a b = compare (assocs a) (assocs b) + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + showList = showList__ (showsPrec 0) + +{- +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) + readList = readList__ (readsPrec 0) +-} +\end{code} + + +%********************************************************* +%* * \subsection{Operations on mutable arrays} %* * %********************************************************* @@ -216,208 +261,40 @@ might be different, though. \begin{code} newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) -newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray - :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) {-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt) #-} -{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-} - newArray (l,u) init = ST $ \ s# -> case rangeSize (l,u) of { I# n# -> case (newArray# n# init s#) of { (# s2#, arr# #) -> (# s2#, MutableArray l u arr# #) }} -newCharArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newCharArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newIntArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newIntArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newWordArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newWordArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newAddrArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newAddrArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newFloatArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newFloatArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} -newDoubleArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newDoubleArray# n# s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) - {-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-} - boundsOfArray (MutableArray l u _) = (l,u) readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt - -readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char -readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int -readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word -readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr -readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float -readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double - {-# SPECIALIZE readArray :: MutableArray s Int elt -> Int -> ST s elt, MutableArray s IPr elt -> IPr -> ST s elt #-} -{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-} -{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-} -{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-} ---NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-} -{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-} readArray (MutableArray l u arr#) n = ST $ \ s# -> case (index (l,u) n) of { I# n# -> case readArray# arr# n# s# of { (# s2#, r #) -> (# s2#, r #) }} -readCharArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readCharArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, C# r# #) }} - -readIntArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readIntArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, I# r# #) }} - -readWordArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readWordArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, W# r# #) }} - -readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readAddrArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, A# r# #) }} - -readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readFloatArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, F# r# #) }} - -readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readDoubleArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, D# r# #) }} - ---Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here. -indexCharArray :: Ix ix => ByteArray ix -> ix -> Char -indexIntArray :: Ix ix => ByteArray ix -> ix -> Int -indexWordArray :: Ix ix => ByteArray ix -> ix -> Word -indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr -indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float -indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double - -{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-} -{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-} -{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-} ---NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-} -{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-} - -indexCharArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexCharArray# barr# n# of { r# -> - (C# r#)}} - -indexIntArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexIntArray# barr# n# of { r# -> - (I# r#)}} - -indexWordArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexWordArray# barr# n# of { r# -> - (W# r#)}} - -indexAddrArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexAddrArray# barr# n# of { r# -> - (A# r#)}} - -indexFloatArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexFloatArray# barr# n# of { r# -> - (F# r#)}} - -indexDoubleArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexDoubleArray# barr# n# of { r# -> - (D# r#)}} - writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () -writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () -writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () -writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s () -writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s () -writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () -writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () - {-# SPECIALIZE writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (), MutableArray s IPr elt -> IPr -> elt -> ST s () #-} -{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} -{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} -{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-} ---NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} -{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} writeArray (MutableArray l u arr#) n ele = ST $ \ s# -> case index (l,u) n of { I# n# -> case writeArray# arr# n# ele s# of { s2# -> (# s2#, () #) }} - -writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeCharArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeIntArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeWordArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeAddrArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeFloatArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeDoubleArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} \end{code} @@ -429,15 +306,9 @@ writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# -> \begin{code} freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - {-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt), MutableArray s IPr elt -> ST s (Array IPr elt) #-} -{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} freezeArray (MutableArray l u arr#) = ST $ \ s# -> case rangeSize (l,u) of { I# n# -> @@ -471,148 +342,19 @@ freezeArray (MutableArray l u arr#) = ST $ \ s# -> copy (cur# +# 1#) end# from# to# s2# }} -freezeCharArray (MutableByteArray l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze arr1# n# s1# - = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = case (readCharArray# from# cur# st#) of { (# s2#, ele #) -> - case (writeCharArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -freezeIntArray (MutableByteArray l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze m_arr# n# s# - = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# s1# - | cur# ==# end# - = (# s1#, to# #) - | otherwise - = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) -> - case (writeIntArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -freezeWordArray (MutableByteArray l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze m_arr# n# s1# - = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# st# - | cur# ==# end# = (# st#, to# #) - | otherwise = - case (readWordArray# from# cur# st#) of { (# s2#, ele #) -> - case (writeWordArray# to# cur# ele s2#) of { s3# -> - copy (cur# +# 1#) end# from# to# s3# - }} - -freezeAddrArray (MutableByteArray l u arr#) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case freeze arr# n# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) }} - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> (# State# s, ByteArray# #) - - freeze m_arr# n# s1# - = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) -> - case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> (# State# s, MutableByteArray# s #) - - copy cur# end# from# to# st# - | cur# ==# end# - = (# st#, to# #) - | otherwise - = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) -> - case (writeAddrArray# to# cur# ele st1#) of { st2# -> - copy (cur# +# 1#) end# from# to# st2# - }} - unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) - #-} - unsafeFreezeArray (MutableArray l u arr#) = ST $ \ s# -> case unsafeFreezeArray# arr# s# of { (# s2#, frozen# #) -> (# s2#, Array l u frozen# #) } -unsafeFreezeByteArray (MutableByteArray l u arr#) = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) } - - --This takes a immutable array, and copies it into a mutable array, in a --hurry. +thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) {-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt), Array IPr elt -> ST s (MutableArray s IPr elt) #-} -thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) thawArray (Array l u arr#) = ST $ \ s# -> case rangeSize (l,u) of { I# n# -> case thaw arr# n# s# of { (# s2#, thawed# #) -> diff --git a/ghc/lib/std/PrelArrExtra.lhs b/ghc/lib/std/PrelArrExtra.lhs index 7c267fccc4..840e9dd7c8 100644 --- a/ghc/lib/std/PrelArrExtra.lhs +++ b/ghc/lib/std/PrelArrExtra.lhs @@ -15,6 +15,7 @@ module PrelArrExtra where import Ix import PrelArr +import PrelByteArr import PrelST import PrelBase import PrelGHC diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 89b0694448..dcf8f31058 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -4,6 +4,72 @@ \section[PrelBase]{Module @PrelBase@} +The overall structure of the GHC Prelude is a bit tricky. + + a) We want to avoid "orphan modules", i.e. ones with instance + decls that don't belong either to a tycon or a class + defined in the same module + + b) We want to avoid giant modules + +So the rough structure is as follows, in (linearised) dependency order + + +PrelGHC Has no implementation. It defines built-in things, and + by importing it you bring them into scope. + The source file is PrelGHC.hi-boot, which is just + copied to make PrelGHC.hi + + Classes: CCallable, CReturnable + +PrelBase Classes: Eq, Ord, Functor, Monad + Types: list, (), Int, Bool, Ordering, Char, String + +PrelTup Types: tuples, plus instances for PrelBase classes + +PrelShow Class: Show, plus instances for PrelBase/PrelTup types + +PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types + +PrelMaybe Type: Maybe, plus instances for PrelBase classes + +PrelNum Class: Num, plus instances for Int + Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show) + + Integer is needed here because it is mentioned in the signature + of 'fromInteger' in class Num + +PrelReal Classes: Real, Integral, Fractional, RealFrac + plus instances for Int, Integer + Types: Ratio, Rational + plus intances for classes so far + + Rational is needed here because it is mentioned in the signature + of 'toRational' in class Real + +Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples + +PrelArr Types: Array, MutableArray, MutableVar + + Does *not* contain any ByteArray stuff (see PrelByteArr) + Arrays are used by a function in PrelFloat + +PrelFloat Classes: Floating, RealFloat + Types: Float, Double, plus instances of all classes so far + + This module contains everything to do with floating point. + It is a big module (900 lines) + With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi + +PrelByteArr Types: ByteArray, MutableByteArray + + We want this one to be after PrelFloat, because it defines arrays + of unboxed floats. + + +Other Prelude modules are much easier with fewer complex dependencies. + + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} @@ -25,6 +91,8 @@ infixr 3 && infixr 2 || infixl 1 >>, >>= infixr 0 $ + +default () -- Double isn't available yet \end{code} @@ -360,74 +428,6 @@ compareInt :: Int -> Int -> Ordering %********************************************************* %* * -\subsection{Type @Integer@, @Float@, @Double@} -%* * -%********************************************************* - -\begin{code} -data Float = F# Float# -data Double = D# Double# - -data Integer - = S# Int# -- small integers - | J# Int# ByteArray# -- large integers - -instance Eq Integer where - (S# i) == (S# j) = i ==# j - (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0# - (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0# - (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0# - - (S# i) /= (S# j) = i /=# j - (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0# - (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0# - (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0# - -instance Ord Integer where - (S# i) <= (S# j) = i <=# j - (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0# - (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0# - (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0# - - (S# i) > (S# j) = i ># j - (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0# - (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0# - (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0# - - (S# i) < (S# j) = i <# j - (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0# - (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0# - (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0# - - (S# i) >= (S# j) = i >=# j - (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0# - (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0# - (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0# - - compare (S# i) (S# j) - | i ==# j = EQ - | i <=# j = LT - | otherwise = GT - compare (J# s d) (S# i) - = case cmpIntegerInt# s d i of { res# -> - if res# <# 0# then LT else - if res# ># 0# then GT else EQ - } - compare (S# i) (J# s d) - = case cmpIntegerInt# s d i of { res# -> - if res# ># 0# then LT else - if res# <# 0# then GT else EQ - } - compare (J# s1 d1) (J# s2 d2) - = case cmpInteger# s1 d1 s2 d2 of { res# -> - if res# <# 0# then LT else - if res# ># 0# then GT else EQ - } -\end{code} - - -%********************************************************* -%* * \subsection{The function type} %* * %********************************************************* @@ -469,6 +469,28 @@ asTypeOf = const %********************************************************* %* * +\subsection{CCallable instances} +%* * +%********************************************************* + +Defined here to avoid orphans + +\begin{code} +instance CCallable Char +instance CReturnable Char + +instance CCallable Int +instance CReturnable Int + +-- DsCCall knows how to pass strings... +instance CCallable [Char] + +instance CReturnable () -- Why, exactly? +\end{code} + + +%********************************************************* +%* * \subsection{Numeric primops} %* * %********************************************************* @@ -490,16 +512,30 @@ used in the case of partial applications, etc. {-# INLINE remInt #-} {-# INLINE negateInt #-} -plusInt, minusInt, timesInt, quotInt, remInt :: Int -> Int -> Int +plusInt, minusInt, timesInt, quotInt, remInt, gcdInt :: Int -> Int -> Int plusInt (I# x) (I# y) = I# (x +# y) minusInt(I# x) (I# y) = I# (x -# y) timesInt(I# x) (I# y) = I# (x *# y) quotInt (I# x) (I# y) = I# (quotInt# x y) remInt (I# x) (I# y) = I# (remInt# x y) +gcdInt (I# a) (I# b) = I# (gcdInt# a b) negateInt :: Int -> Int negateInt (I# x) = I# (negateInt# x) +divInt, modInt :: Int -> Int -> Int +x `divInt` y + | x > zeroInt && y < zeroInt = quotInt ((x `minusInt` y) `minusInt` oneInt) y + | x < zeroInt && y > zeroInt = quotInt ((x `minusInt` y) `plusInt` oneInt) y + | otherwise = quotInt x y + +x `modInt` y + | x > zeroInt && y < zeroInt || + x < zeroInt && y > zeroInt = if r/=zeroInt then r `plusInt` y else zeroInt + | otherwise = r + where + r = remInt x y + gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool gtInt (I# x) (I# y) = x ># y geInt (I# x) (I# y) = x >=# y @@ -509,14 +545,3 @@ ltInt (I# x) (I# y) = x <# y leInt (I# x) (I# y) = x <=# y \end{code} -Convenient boxed Integer PrimOps. These are 'thin-air' Ids, so -it's nice to have them in PrelBase. - -\begin{code} -{-# INLINE int2Integer #-} -{-# INLINE addr2Integer #-} -int2Integer :: Int# -> Integer -int2Integer i = S# i -addr2Integer :: Addr# -> Integer -addr2Integer x = case addr2Integer# x of (# s, d #) -> J# s d -\end{code} diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs new file mode 100644 index 0000000000..3973c741c1 --- /dev/null +++ b/ghc/lib/std/PrelByteArr.lhs @@ -0,0 +1,377 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% +\section[PrelByteArr]{Module @PrelByteArr@} + +Byte-arrays are flat arrays of non-pointers only. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelByteArr where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelArr +import PrelFloat +import Ix +import PrelList (foldl) +import PrelST +import PrelBase +import PrelAddr +import PrelGHC + +\end{code} + +%********************************************************* +%* * +\subsection{The @Array@ types} +%* * +%********************************************************* + +\begin{code} +data Ix ix => ByteArray ix = ByteArray ix ix ByteArray# +data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + +instance CCallable (MutableByteArray s ix) +instance CCallable (ByteArray ix) + +instance Eq (MutableByteArray s ix) where + MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2# + = sameMutableByteArray# arr1# arr2# +\end{code} + +%********************************************************* +%* * +\subsection{Operations on mutable arrays} +%* * +%********************************************************* + +Idle ADR question: What's the tradeoff here between flattening these +datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using +it as is? As I see it, the former uses slightly less heap and +provides faster access to the individual parts of the bounds while the +code used has the benefit of providing a ready-made @(lo, hi)@ pair as +required by many array-related functions. Which wins? Is the +difference significant (probably not). + +Idle AJG answer: When I looked at the outputted code (though it was 2 +years ago) it seems like you often needed the tuple, and we build +it frequently. Now we've got the overloading specialiser things +might be different, though. + +\begin{code} +newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray + :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) + +{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-} + +newCharArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newCharArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + +newIntArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newIntArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + +newWordArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newWordArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + +newAddrArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newAddrArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + +newFloatArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newFloatArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + +newDoubleArray (l,u) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case (newDoubleArray# n# s#) of { (# s2#, barr# #) -> + (# s2#, MutableByteArray l u barr# #) }} + + +readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char +readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int +readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word +readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr +readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float +readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double + +{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-} +{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-} +{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-} +--NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-} +{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-} + +readCharArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readCharArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, C# r# #) }} + +readIntArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readIntArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, I# r# #) }} + +readWordArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readWordArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, W# r# #) }} + +readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readAddrArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, A# r# #) }} + +readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readFloatArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, F# r# #) }} + +readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# -> + case (index (l,u) n) of { I# n# -> + case readDoubleArray# barr# n# s# of { (# s2#, r# #) -> + (# s2#, D# r# #) }} + +--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here. +indexCharArray :: Ix ix => ByteArray ix -> ix -> Char +indexIntArray :: Ix ix => ByteArray ix -> ix -> Int +indexWordArray :: Ix ix => ByteArray ix -> ix -> Word +indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr +indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float +indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double + +{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-} +{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-} +{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-} +--NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-} +{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-} + +indexCharArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexCharArray# barr# n# of { r# -> + (C# r#)}} + +indexIntArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexIntArray# barr# n# of { r# -> + (I# r#)}} + +indexWordArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexWordArray# barr# n# of { r# -> + (W# r#)}} + +indexAddrArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexAddrArray# barr# n# of { r# -> + (A# r#)}} + +indexFloatArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexFloatArray# barr# n# of { r# -> + (F# r#)}} + +indexDoubleArray (ByteArray l u barr#) n + = case (index (l,u) n) of { I# n# -> + case indexDoubleArray# barr# n# of { r# -> + (D# r#)}} + +writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () +writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () +writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s () +writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s () +writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () +writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () + +{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} +{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} +{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-} +--NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} +{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} + +writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeCharArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} + +writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeIntArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} + +writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeWordArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} + +writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeAddrArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} + +writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeFloatArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} + +writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# -> + case index (l,u) n of { I# n# -> + case writeDoubleArray# barr# n# ele s# of { s2# -> + (# s2#, () #) }} +\end{code} + + +%********************************************************* +%* * +\subsection{Moving between mutable and immutable} +%* * +%********************************************************* + +\begin{code} +freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) + +{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} + +freezeCharArray (MutableByteArray l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case freeze arr# n# s# of { (# s2#, frozen# #) -> + (# s2#, ByteArray l u frozen# #) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> (# State# s, ByteArray# #) + + freeze arr1# n# s1# + = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> (# State# s, MutableByteArray# s #) + + copy cur# end# from# to# st# + | cur# ==# end# + = (# st#, to# #) + | otherwise + = case (readCharArray# from# cur# st#) of { (# s2#, ele #) -> + case (writeCharArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# + }} + +freezeIntArray (MutableByteArray l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case freeze arr# n# s# of { (# s2#, frozen# #) -> + (# s2#, ByteArray l u frozen# #) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> (# State# s, ByteArray# #) + + freeze m_arr# n# s# + = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> (# State# s, MutableByteArray# s #) + + copy cur# end# from# to# s1# + | cur# ==# end# + = (# s1#, to# #) + | otherwise + = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) -> + case (writeIntArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# + }} + +freezeWordArray (MutableByteArray l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case freeze arr# n# s# of { (# s2#, frozen# #) -> + (# s2#, ByteArray l u frozen# #) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> (# State# s, ByteArray# #) + + freeze m_arr# n# s1# + = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> (# State# s, MutableByteArray# s #) + + copy cur# end# from# to# st# + | cur# ==# end# = (# st#, to# #) + | otherwise = + case (readWordArray# from# cur# st#) of { (# s2#, ele #) -> + case (writeWordArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# + }} + +freezeAddrArray (MutableByteArray l u arr#) = ST $ \ s# -> + case rangeSize (l,u) of { I# n# -> + case freeze arr# n# s# of { (# s2#, frozen# #) -> + (# s2#, ByteArray l u frozen# #) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> (# State# s, ByteArray# #) + + freeze m_arr# n# s1# + = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> (# State# s, MutableByteArray# s #) + + copy cur# end# from# to# st# + | cur# ==# end# + = (# st#, to# #) + | otherwise + = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) -> + case (writeAddrArray# to# cur# ele st1#) of { st2# -> + copy (cur# +# 1#) end# from# to# st2# + }} + +unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) + +{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) + #-} + +unsafeFreezeByteArray (MutableByteArray l u arr#) = ST $ \ s# -> + case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> + (# s2#, ByteArray l u frozen# #) } +\end{code} diff --git a/ghc/lib/std/PrelCCall.lhs b/ghc/lib/std/PrelCCall.lhs deleted file mode 100644 index d8c1eb4f4b..0000000000 --- a/ghc/lib/std/PrelCCall.lhs +++ /dev/null @@ -1,43 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1996 -% - -\section[PrelCCall]{Module @PrelCCall@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelCCall ( - CCallable(..), - CReturnable(..) - ) where - -import PrelBase -import PrelGHC -\end{code} - -%********************************************************* -%* * -\subsection{Classes @CCallable@ and @CReturnable@} -%* * -%********************************************************* - -\begin{code} -instance CCallable Char -instance CReturnable Char - -instance CCallable Int -instance CReturnable Int - --- DsCCall knows how to pass strings... -instance CCallable [Char] - -instance CCallable Float -instance CReturnable Float - -instance CCallable Double -instance CReturnable Double - -instance CReturnable () -- Why, exactly? -\end{code} - diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs index e327827f48..f2b7b0180f 100644 --- a/ghc/lib/std/PrelConc.lhs +++ b/ghc/lib/std/PrelConc.lhs @@ -44,7 +44,7 @@ import PrelIOBase ( IO(..), MVar(..), unsafePerformIO ) import PrelBase ( Int(..) ) import PrelException ( Exception(..), AsyncException(..) ) -infixr 0 `par` +infixr 0 `par`, `seq` \end{code} %************************************************************************ diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs index 2ace283077..2b0f5bd5af 100644 --- a/ghc/lib/std/PrelEnum.lhs +++ b/ghc/lib/std/PrelEnum.lhs @@ -19,6 +19,8 @@ module PrelEnum( import {-# SOURCE #-} PrelErr ( error ) import PrelBase import PrelTup () -- To make sure we look for the .hi file + +default () -- Double isn't available yet \end{code} diff --git a/ghc/lib/std/PrelFloat.lhs b/ghc/lib/std/PrelFloat.lhs new file mode 100644 index 0000000000..bb85dcc7be --- /dev/null +++ b/ghc/lib/std/PrelFloat.lhs @@ -0,0 +1,892 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelNum]{Module @PrelNum@} + +The types + + Float + Double + +and the classes + + Floating + RealFloat + + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +#include "../includes/ieee-flpt.h" + +module PrelFloat where + +import {-# SOURCE #-} PrelErr +import PrelBase +import PrelList +import PrelEnum +import PrelShow +import PrelNum +import PrelReal +import PrelArr +import PrelMaybe + +infixr 8 ** +\end{code} + +%********************************************************* +%* * +\subsection{Standard numeric classes} +%* * +%********************************************************* + +\begin{code} +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + tanh x = sinh x / cosh x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE + :: a -> Bool + atan2 :: a -> a -> a + + + exponent x = if m == 0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + + significand x = encodeFloat m (negate (floatDigits x)) + where (m,_) = decodeFloat x + + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + + atan2 y x + | x > 0 = atan (y/x) + | x == 0 && y > 0 = pi/2 + | x < 0 && y > 0 = pi + atan (y/x) + |(x <= 0 && y < 0) || + (x < 0 && isNegativeZero y) || + (isNegativeZero x && isNegativeZero y) + = -atan2 (-y) x + | y == 0 && (x < 0 || isNegativeZero x) + = pi -- must be after the previous test on zero y + | x==0 && y==0 = y -- must be after the other double zero tests + | otherwise = x + y -- x or y is a NaN, return a NaN (via +) +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Integer@, @Float@, @Double@} +%* * +%********************************************************* + +\begin{code} +data Float = F# Float# +data Double = D# Double# + +instance CCallable Float +instance CReturnable Float + +instance CCallable Double +instance CReturnable Double +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Float@} +%* * +%********************************************************* + +\begin{code} +instance Eq Float where + (F# x) == (F# y) = x `eqFloat#` y + +instance Ord Float where + (F# x) `compare` (F# y) | x `ltFloat#` y = LT + | x `eqFloat#` y = EQ + | otherwise = GT + + (F# x) < (F# y) = x `ltFloat#` y + (F# x) <= (F# y) = x `leFloat#` y + (F# x) >= (F# y) = x `geFloat#` y + (F# x) > (F# y) = x `gtFloat#` y + +instance Num Float where + (+) x y = plusFloat x y + (-) x y = minusFloat x y + negate x = negateFloat x + (*) x y = timesFloat x y + abs x | x >= 0.0 = x + | otherwise = negateFloat x + signum x | x == 0.0 = 0 + | x > 0.0 = 1 + | otherwise = negate 1 + + {-# INLINE fromInteger #-} + fromInteger n = encodeFloat n 0 + -- It's important that encodeFloat inlines here, and that + -- fromInteger in turn inlines, + -- so that if fromInteger is applied to an (S# i) the right thing happens + + {-# INLINE fromInt #-} + fromInt i = int2Float i + +instance Real Float where + toRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Float where + (/) x y = divideFloat x y + fromRational x = fromRat x + recip x = 1.0 / x + +instance RealFrac Float where + + {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} + {-# SPECIALIZE truncate :: Float -> Int #-} + {-# SPECIALIZE round :: Float -> Int #-} + {-# SPECIALIZE ceiling :: Float -> Int #-} + {-# SPECIALIZE floor :: Float -> Int #-} + + {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-} + {-# SPECIALIZE truncate :: Float -> Integer #-} + {-# SPECIALIZE round :: Float -> Integer #-} + {-# SPECIALIZE ceiling :: Float -> Integer #-} + {-# SPECIALIZE floor :: Float -> Integer #-} + + properFraction x + = case (decodeFloat x) of { (m,n) -> + let b = floatRadix x in + if n >= 0 then + (fromInteger m * fromInteger b ^ n, 0.0) + else + case (quotRem m (b^(negate n))) of { (w,r) -> + (fromInteger w, encodeFloat r n) + } + } + + truncate x = case properFraction x of + (n,_) -> n + + round x = case properFraction x of + (n,r) -> let + m = if r < 0.0 then n - 1 else n + 1 + half_down = abs r - 0.5 + in + case (compare half_down 0.0) of + LT -> n + EQ -> if even n then n else m + GT -> m + + ceiling x = case properFraction x of + (n,r) -> if r > 0.0 then n + 1 else n + + floor x = case properFraction x of + (n,r) -> if r < 0.0 then n - 1 else n + +instance Floating Float where + pi = 3.141592653589793238 + exp x = expFloat x + log x = logFloat x + sqrt x = sqrtFloat x + sin x = sinFloat x + cos x = cosFloat x + tan x = tanFloat x + asin x = asinFloat x + acos x = acosFloat x + atan x = atanFloat x + sinh x = sinhFloat x + cosh x = coshFloat x + tanh x = tanhFloat x + (**) x y = powerFloat x y + logBase x y = log y / log x + + asinh x = log (x + sqrt (1.0+x*x)) + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + atanh x = log ((x+1.0) / sqrt (1.0-x*x)) + +instance RealFloat Float where + floatRadix _ = FLT_RADIX -- from float.h + floatDigits _ = FLT_MANT_DIG -- ditto + floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto + + decodeFloat (F# f#) + = case decodeFloat# f# of + (# exp#, s#, d# #) -> (J# s# d#, I# exp#) + + encodeFloat (S# i) j = int_encodeFloat# i j + encodeFloat (J# s# d#) e = encodeFloat# s# d# e + + exponent x = case decodeFloat x of + (m,n) -> if m == 0 then 0 else n + floatDigits x + + significand x = case decodeFloat x of + (m,_) -> encodeFloat m (negate (floatDigits x)) + + scaleFloat k x = case decodeFloat x of + (m,n) -> encodeFloat m (n+k) + isNaN x = 0 /= isFloatNaN x + isInfinite x = 0 /= isFloatInfinite x + isDenormalized x = 0 /= isFloatDenormalized x + isNegativeZero x = 0 /= isFloatNegativeZero x + isIEEE _ = True + +instance Show Float where + showsPrec x = showSigned showFloat x + showList = showList__ (showsPrec 0) +\end{code} + +%********************************************************* +%* * +\subsection{Type @Double@} +%* * +%********************************************************* + +\begin{code} +instance Eq Double where + (D# x) == (D# y) = x ==## y + +instance Ord Double where + (D# x) `compare` (D# y) | x <## y = LT + | x ==## y = EQ + | otherwise = GT + + (D# x) < (D# y) = x <## y + (D# x) <= (D# y) = x <=## y + (D# x) >= (D# y) = x >=## y + (D# x) > (D# y) = x >## y + +instance Num Double where + (+) x y = plusDouble x y + (-) x y = minusDouble x y + negate x = negateDouble x + (*) x y = timesDouble x y + abs x | x >= 0.0 = x + | otherwise = negateDouble x + signum x | x == 0.0 = 0 + | x > 0.0 = 1 + | otherwise = negate 1 + + {-# INLINE fromInteger #-} + -- See comments with Num Float + fromInteger n = encodeFloat n 0 + fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# } + +instance Real Double where + toRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Double where + (/) x y = divideDouble x y + fromRational x = fromRat x + recip x = 1.0 / x + +instance Floating Double where + pi = 3.141592653589793238 + exp x = expDouble x + log x = logDouble x + sqrt x = sqrtDouble x + sin x = sinDouble x + cos x = cosDouble x + tan x = tanDouble x + asin x = asinDouble x + acos x = acosDouble x + atan x = atanDouble x + sinh x = sinhDouble x + cosh x = coshDouble x + tanh x = tanhDouble x + (**) x y = powerDouble x y + logBase x y = log y / log x + + asinh x = log (x + sqrt (1.0+x*x)) + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + atanh x = log ((x+1.0) / sqrt (1.0-x*x)) + +instance RealFrac Double where + + {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} + {-# SPECIALIZE truncate :: Double -> Int #-} + {-# SPECIALIZE round :: Double -> Int #-} + {-# SPECIALIZE ceiling :: Double -> Int #-} + {-# SPECIALIZE floor :: Double -> Int #-} + + {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-} + {-# SPECIALIZE truncate :: Double -> Integer #-} + {-# SPECIALIZE round :: Double -> Integer #-} + {-# SPECIALIZE ceiling :: Double -> Integer #-} + {-# SPECIALIZE floor :: Double -> Integer #-} + + properFraction x + = case (decodeFloat x) of { (m,n) -> + let b = floatRadix x in + if n >= 0 then + (fromInteger m * fromInteger b ^ n, 0.0) + else + case (quotRem m (b^(negate n))) of { (w,r) -> + (fromInteger w, encodeFloat r n) + } + } + + truncate x = case properFraction x of + (n,_) -> n + + round x = case properFraction x of + (n,r) -> let + m = if r < 0.0 then n - 1 else n + 1 + half_down = abs r - 0.5 + in + case (compare half_down 0.0) of + LT -> n + EQ -> if even n then n else m + GT -> m + + ceiling x = case properFraction x of + (n,r) -> if r > 0.0 then n + 1 else n + + floor x = case properFraction x of + (n,r) -> if r < 0.0 then n - 1 else n + +instance RealFloat Double where + floatRadix _ = FLT_RADIX -- from float.h + floatDigits _ = DBL_MANT_DIG -- ditto + floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto + + decodeFloat (D# x#) + = case decodeDouble# x# of + (# exp#, s#, d# #) -> (J# s# d#, I# exp#) + + encodeFloat (S# i) j = int_encodeDouble# i j + encodeFloat (J# s# d#) e = encodeDouble# s# d# e + + exponent x = case decodeFloat x of + (m,n) -> if m == 0 then 0 else n + floatDigits x + + significand x = case decodeFloat x of + (m,_) -> encodeFloat m (negate (floatDigits x)) + + scaleFloat k x = case decodeFloat x of + (m,n) -> encodeFloat m (n+k) + + isNaN x = 0 /= isDoubleNaN x + isInfinite x = 0 /= isDoubleInfinite x + isDenormalized x = 0 /= isDoubleDenormalized x + isNegativeZero x = 0 /= isDoubleNegativeZero x + isIEEE _ = True + +instance Show Double where + showsPrec x = showSigned showFloat x + showList = showList__ (showsPrec 0) +\end{code} + +%********************************************************* +%* * +\subsection{@Enum@ instances} +%* * +%********************************************************* + +The @Enum@ instances for Floats and Doubles are slightly unusual. +The @toEnum@ function truncates numbers to Int. The definitions +of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic +series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat +dubious. This example may have either 10 or 11 elements, depending on +how 0.1 is represented. + +NOTE: The instances for Float and Double do not make use of the default +methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being +a `non-lossy' conversion to and from Ints. Instead we make use of the +1.2 default methods (back in the days when Enum had Ord as a superclass) +for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) + +\begin{code} +instance Enum Float where + succ x = x + 1 + pred x = x - 1 + toEnum = fromInt + fromEnum = fromInteger . truncate -- may overflow + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +instance Enum Double where + succ x = x + 1 + pred x = x - 1 + toEnum = fromInt + fromEnum = fromInteger . truncate -- may overflow + enumFrom = numericEnumFrom + enumFromTo = numericEnumFromTo + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +numericEnumFrom :: (Fractional a) => a -> [a] +numericEnumFrom = iterate (+1) + +numericEnumFromThen :: (Fractional a) => a -> a -> [a] +numericEnumFromThen n m = iterate (+(m-n)) n + +numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a] +numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n) + +numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a] +numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2) + where + mid = (e2 - e1) / 2 + pred | e2 > e1 = (<= e3 + mid) + | otherwise = (>= e3 + mid) +\end{code} + + +%********************************************************* +%* * +\subsection{Printing floating point} +%* * +%********************************************************* + + +\begin{code} +showFloat :: (RealFloat a) => a -> ShowS +showFloat x = showString (formatRealFloat FFGeneric Nothing x) + +-- These are the format types. This type is not exported. + +data FFFormat = FFExponent | FFFixed | FFGeneric + +formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String +formatRealFloat fmt decs x + | isNaN x = "NaN" + | isInfinite x = if x < 0 then "-Infinity" else "Infinity" + | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x)) + | otherwise = doFmt fmt (floatToDigits (toInteger base) x) + where + base = 10 + + doFmt format (is, e) = + let ds = map intToDigit is in + case format of + FFGeneric -> + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) + (is,e) + FFExponent -> + case decs of + Nothing -> + let show_e' = show (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> d : ".0e" ++ show_e' + (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0" + _ -> + let + (ei,is') = roundTo base (dec'+1) is + (d:ds') = map intToDigit (if ei > 0 then init is' else is') + in + d:'.':ds' ++ 'e':show (e-1+ei) + FFFixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> ls} + in + case decs of + Nothing -> + let + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo base (dec' + e) is + (ls,rs) = splitAt (e+ei) (map intToDigit is') + in + mk0 ls ++ (if null rs then "" else '.':rs) + else + let + (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is) + d:ds' = map intToDigit (if ei > 0 then is' else 0:is') + in + d : '.' : ds' + + +roundTo :: Int -> Int -> [Int] -> (Int,[Int]) +roundTo base d is = + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + where + b2 = base `div` 2 + + f n [] = (0, replicate n 0) + f 0 (x:_) = (if x >= b2 then 1 else 0, []) + f n (i:xs) + | i' == base = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) xs + i' = c + i + +-- +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R.K. Dybvig in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- This function returns a list of digits (Ints in [0..base-1]) and an +-- exponent. + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) +floatToDigits _ 0 = ([0], 0) +floatToDigits base x = + let + (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = + let n = minExp - e0 in + if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + (r, s, mUp, mDn) = + if e >= 0 then + let be = b^ e in + if f == b^(p-1) then + (f*be*b*2, 2*b, be*b, b) + else + (f*be*2, 2, be, be) + else + if e > minExp && f == b^(p-1) then + (f*b*2, b^(-e+1)*2, b, 1) + else + (f*2, b^(-e)*2, 1, 1) + k = + let + k0 = + if b == 2 && base == 10 then + -- logBase 10 2 is slightly bigger than 3/10 so + -- the following will err on the low side. Ignoring + -- the fraction will make it err even more. + -- Haskell promises that p-1 <= logBase b f < p. + (p - 1 + e0) * 3 `div` 10 + else + ceiling ((log (fromInteger (f+1)) + + fromInt e * log (fromInteger b)) / + log (fromInteger base)) +--WAS: fromInt e * log (fromInteger b)) + + fixup n = + if n >= 0 then + if r + mUp <= expt base n * s then n else fixup (n+1) + else + if expt base (-n) * (r + mUp) <= s then n else fixup (n+1) + in + fixup k0 + + gen ds rn sN mUpN mDnN = + let + (dn, rn') = (rn * base) `divMod` sN + mUpN' = mUpN * base + mDnN' = mDnN * base + in + case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + + rds = + if k >= 0 then + gen [] r (s * expt base k) mUp mDn + else + let bk = expt base (-k) in + gen [] (r * bk) s (mUp * bk) (mDn * bk) + in + (map toInt (reverse rds), k) + +\end{code} + + +%********************************************************* +%* * +\subsection{Converting from a Rational to a RealFloat +%* * +%********************************************************* + +[In response to a request for documentation of how fromRational works, +Joe Fasel writes:] A quite reasonable request! This code was added to +the Prelude just before the 1.2 release, when Lennart, working with an +early version of hbi, noticed that (read . show) was not the identity +for floating-point numbers. (There was a one-bit error about half the +time.) The original version of the conversion function was in fact +simply a floating-point divide, as you suggest above. The new version +is, I grant you, somewhat denser. + +Unfortunately, Joe's code doesn't work! Here's an example: + +main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n") + +This program prints + 0.0000000000000000 +instead of + 1.8217369128763981e-300 + +Here's Joe's code: + +\begin{pseudocode} +fromRat :: (RealFloat a) => Rational -> a +fromRat x = x' + where x' = f e + +-- If the exponent of the nearest floating-point number to x +-- is e, then the significand is the integer nearest xb^(-e), +-- where b is the floating-point radix. We start with a good +-- guess for e, and if it is correct, the exponent of the +-- floating-point number we construct will again be e. If +-- not, one more iteration is needed. + + f e = if e' == e then y else f e' + where y = encodeFloat (round (x * (1 % b)^^e)) e + (_,e') = decodeFloat y + b = floatRadix x' + +-- We obtain a trial exponent by doing a floating-point +-- division of x's numerator by its denominator. The +-- result of this division may not itself be the ultimate +-- result, because of an accumulation of three rounding +-- errors. + + (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' + / fromInteger (denominator x)) +\end{pseudocode} + +Now, here's Lennart's code (which works) + +\begin{code} +{-# SPECIALISE fromRat :: + Rational -> Double, + Rational -> Float #-} +fromRat :: (RealFloat a) => Rational -> a +fromRat x + | x == 0 = encodeFloat 0 0 -- Handle exceptional cases + | x < 0 = - fromRat' (-x) -- first. + | otherwise = fromRat' x + +-- Conversion process: +-- Scale the rational number by the RealFloat base until +-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat). +-- Then round the rational to an Integer and encode it with the exponent +-- that we got from the scaling. +-- To speed up the scaling process we compute the log2 of the number to get +-- a first guess of the exponent. + +fromRat' :: (RealFloat a) => Rational -> a +fromRat' x = r + where b = floatRadix r + p = floatDigits r + (minExp0, _) = floatRange r + minExp = minExp0 - p -- the real minimum exponent + xMin = toRational (expt b (p-1)) + xMax = toRational (expt b p) + p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp + f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1 + (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f) + r = encodeFloat (round x') p' + +-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp. +scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int) +scaleRat b minExp xMin xMax p x + | p <= minExp = (x, p) + | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b) + | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b) + | otherwise = (x, p) + +-- Exponentiation with a cache for the most common numbers. +minExpt, maxExpt :: Int +minExpt = 0 +maxExpt = 1100 + +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts!n + else + base^n + +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +-- Compute the (floor of the) log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i + | i < b = 0 + | otherwise = doDiv (i `div` (b^l)) l + where + -- Try squaring the base first to cut down the number of divisions. + l = 2 * integerLogBase (b*b) i + + doDiv :: Integer -> Int -> Int + doDiv x y + | x < b = y + | otherwise = doDiv (x `div` b) (y+1) + +\end{code} + + +%********************************************************* +%* * +\subsection{Floating point numeric primops} +%* * +%********************************************************* + +Definitions of the boxed PrimOps; these will be +used in the case of partial applications, etc. + +\begin{code} +plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float +plusFloat (F# x) (F# y) = F# (plusFloat# x y) +minusFloat (F# x) (F# y) = F# (minusFloat# x y) +timesFloat (F# x) (F# y) = F# (timesFloat# x y) +divideFloat (F# x) (F# y) = F# (divideFloat# x y) + +negateFloat :: Float -> Float +negateFloat (F# x) = F# (negateFloat# x) + +gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool +gtFloat (F# x) (F# y) = gtFloat# x y +geFloat (F# x) (F# y) = geFloat# x y +eqFloat (F# x) (F# y) = eqFloat# x y +neFloat (F# x) (F# y) = neFloat# x y +ltFloat (F# x) (F# y) = ltFloat# x y +leFloat (F# x) (F# y) = leFloat# x y + +float2Int :: Float -> Int +float2Int (F# x) = I# (float2Int# x) + +int2Float :: Int -> Float +int2Float (I# x) = F# (int2Float# x) + +expFloat, logFloat, sqrtFloat :: Float -> Float +sinFloat, cosFloat, tanFloat :: Float -> Float +asinFloat, acosFloat, atanFloat :: Float -> Float +sinhFloat, coshFloat, tanhFloat :: Float -> Float +expFloat (F# x) = F# (expFloat# x) +logFloat (F# x) = F# (logFloat# x) +sqrtFloat (F# x) = F# (sqrtFloat# x) +sinFloat (F# x) = F# (sinFloat# x) +cosFloat (F# x) = F# (cosFloat# x) +tanFloat (F# x) = F# (tanFloat# x) +asinFloat (F# x) = F# (asinFloat# x) +acosFloat (F# x) = F# (acosFloat# x) +atanFloat (F# x) = F# (atanFloat# x) +sinhFloat (F# x) = F# (sinhFloat# x) +coshFloat (F# x) = F# (coshFloat# x) +tanhFloat (F# x) = F# (tanhFloat# x) + +powerFloat :: Float -> Float -> Float +powerFloat (F# x) (F# y) = F# (powerFloat# x y) + +-- definitions of the boxed PrimOps; these will be +-- used in the case of partial applications, etc. + +plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double +plusDouble (D# x) (D# y) = D# (x +## y) +minusDouble (D# x) (D# y) = D# (x -## y) +timesDouble (D# x) (D# y) = D# (x *## y) +divideDouble (D# x) (D# y) = D# (x /## y) + +negateDouble :: Double -> Double +negateDouble (D# x) = D# (negateDouble# x) + +gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool +gtDouble (D# x) (D# y) = x >## y +geDouble (D# x) (D# y) = x >=## y +eqDouble (D# x) (D# y) = x ==## y +neDouble (D# x) (D# y) = x /=## y +ltDouble (D# x) (D# y) = x <## y +leDouble (D# x) (D# y) = x <=## y + +double2Int :: Double -> Int +double2Int (D# x) = I# (double2Int# x) + +int2Double :: Int -> Double +int2Double (I# x) = D# (int2Double# x) + +double2Float :: Double -> Float +double2Float (D# x) = F# (double2Float# x) +float2Double :: Float -> Double +float2Double (F# x) = D# (float2Double# x) + +expDouble, logDouble, sqrtDouble :: Double -> Double +sinDouble, cosDouble, tanDouble :: Double -> Double +asinDouble, acosDouble, atanDouble :: Double -> Double +sinhDouble, coshDouble, tanhDouble :: Double -> Double +expDouble (D# x) = D# (expDouble# x) +logDouble (D# x) = D# (logDouble# x) +sqrtDouble (D# x) = D# (sqrtDouble# x) +sinDouble (D# x) = D# (sinDouble# x) +cosDouble (D# x) = D# (cosDouble# x) +tanDouble (D# x) = D# (tanDouble# x) +asinDouble (D# x) = D# (asinDouble# x) +acosDouble (D# x) = D# (acosDouble# x) +atanDouble (D# x) = D# (atanDouble# x) +sinhDouble (D# x) = D# (sinhDouble# x) +coshDouble (D# x) = D# (coshDouble# x) +tanhDouble (D# x) = D# (tanhDouble# x) + +powerDouble :: Double -> Double -> Double +powerDouble (D# x) (D# y) = D# (x **## y) +\end{code} + +\begin{code} +foreign import ccall "__encodeFloat" unsafe + encodeFloat# :: Int# -> ByteArray# -> Int -> Float +foreign import ccall "__int_encodeFloat" unsafe + int_encodeFloat# :: Int# -> Int -> Float + + +foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int +foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int +foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int +foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int + + +foreign import ccall "__encodeDouble" unsafe + encodeDouble# :: Int# -> ByteArray# -> Int -> Double +foreign import ccall "__int_encodeDouble" unsafe + int_encodeDouble# :: Int# -> Int -> Double + +foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int +foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int +foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int +foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int +\end{code} diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs index 4dc8f3f5ec..859dc18b07 100644 --- a/ghc/lib/std/PrelForeign.lhs +++ b/ghc/lib/std/PrelForeign.lhs @@ -19,7 +19,6 @@ module PrelForeign ( import PrelIOBase import PrelST import PrelBase -import PrelCCall import PrelAddr import PrelGHC \end{code} diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index dba3e67e6c..6d86963e59 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -344,7 +344,7 @@ instance {CCallable Wordzh} = zdfCCallableWordzh; instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh; instance __forall [s] => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; - +instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; -- CCallable and CReturnable have kind (Type AnyBox) so that -- things like Int# can be instances of CCallable. 1 class CCallable a :: ? ; @@ -365,3 +365,4 @@ instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; 1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ; 1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ; 1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; +1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ; diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index 41feadc08b..85289ad873 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -16,17 +16,18 @@ module PrelHandle where import PrelBase import PrelAddr ( Addr, nullAddr ) -import PrelArr ( newVar, readVar, writeVar, ByteArray(..) ) +import PrelArr ( newVar, readVar, writeVar ) +import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase import PrelException import PrelMaybe ( Maybe(..) ) import PrelEnum -import PrelNum +import PrelNum ( toBig, Integer(..), Num(..) ) import PrelShow import PrelAddr ( Addr, nullAddr ) -import PrelNum ( toInteger, toBig ) +import PrelReal ( toInteger ) import PrelPack ( packString ) import PrelWeak ( addForeignFinalizer ) import Ix diff --git a/ghc/lib/std/PrelNum.hi-boot b/ghc/lib/std/PrelNum.hi-boot new file mode 100644 index 0000000000..7c47b0a424 --- /dev/null +++ b/ghc/lib/std/PrelNum.hi-boot @@ -0,0 +1,14 @@ +--------------------------------------------------------------------------- +-- PrelNum.hi-boot +-- +-- This hand-written interface file is the +-- initial bootstrap version for PrelNum.hi. +-- It's needed for the 'thin-air' Id addr2Integer, when compiling +-- PrelBase, and other Prelude files that precede PrelNum +--------------------------------------------------------------------------- + +__interface PrelNum 1 where +__export PrelNum Integer addr2Integer ; + +1 data Integer ; +1 addr2Integer :: PrelGHC.Addrzh -> Integer ; diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs index f70f7269ec..48ed0d9563 100644 --- a/ghc/lib/std/PrelNum.lhs +++ b/ghc/lib/std/PrelNum.lhs @@ -4,6 +4,15 @@ \section[PrelNum]{Module @PrelNum@} +The class + + Num + +and the type + + Integer + + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} @@ -15,16 +24,16 @@ import PrelList import PrelEnum import PrelShow -infixr 8 ^, ^^, ** -infixl 7 %, /, `quot`, `rem`, `div`, `mod` infixl 7 * infixl 6 +, - +default () -- Double isn't available yet, + -- and we shouldn't be using defaults anyway \end{code} %********************************************************* %* * -\subsection{Standard numeric classes} +\subsection{Standard numeric class} %* * %********************************************************* @@ -41,104 +50,20 @@ class (Eq a, Show a) => Num a where fromInt (I# i#) = fromInteger (S# i#) -- Go via the standard class-op if the -- non-standard one ain't provided +\end{code} -class (Num a, Ord a) => Real a where - toRational :: a -> Rational - -class (Real a, Enum a) => Integral a where - quot, rem, div, mod :: a -> a -> a - quotRem, divMod :: a -> a -> (a,a) - toInteger :: a -> Integer - toInt :: a -> Int -- partain: Glasgow extension - - n `quot` d = q where (q,_) = quotRem n d - n `rem` d = r where (_,r) = quotRem n d - n `div` d = q where (q,_) = divMod n d - n `mod` d = r where (_,r) = divMod n d - divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr - where qr@(q,r) = quotRem n d - -class (Num a) => Fractional a where - (/) :: a -> a -> a - recip :: a -> a - fromRational :: Rational -> a - - recip x = 1 / x - x / y = x * recip y - -class (Fractional a) => Floating a where - pi :: a - exp, log, sqrt :: a -> a - (**), logBase :: a -> a -> a - sin, cos, tan :: a -> a - asin, acos, atan :: a -> a - sinh, cosh, tanh :: a -> a - asinh, acosh, atanh :: a -> a - - x ** y = exp (log x * y) - logBase x y = log y / log x - sqrt x = x ** 0.5 - tan x = sin x / cos x - tanh x = sinh x / cosh x - -class (Real a, Fractional a) => RealFrac a where - properFraction :: (Integral b) => a -> (b,a) - truncate, round :: (Integral b) => a -> b - ceiling, floor :: (Integral b) => a -> b - - truncate x = m where (m,_) = properFraction x - - round x = let (n,r) = properFraction x - m = if r < 0 then n - 1 else n + 1 - in case signum (abs r - 0.5) of - -1 -> n - 0 -> if even n then n else m - 1 -> m - - ceiling x = if r > 0 then n + 1 else n - where (n,r) = properFraction x - - floor x = if r < 0 then n - 1 else n - where (n,r) = properFraction x - -class (RealFrac a, Floating a) => RealFloat a where - floatRadix :: a -> Integer - floatDigits :: a -> Int - floatRange :: a -> (Int,Int) - decodeFloat :: a -> (Integer,Int) - encodeFloat :: Integer -> Int -> a - exponent :: a -> Int - significand :: a -> a - scaleFloat :: Int -> a -> a - isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE - :: a -> Bool - atan2 :: a -> a -> a - - - exponent x = if m == 0 then 0 else n + floatDigits x - where (m,n) = decodeFloat x - - significand x = encodeFloat m (negate (floatDigits x)) - where (m,_) = decodeFloat x - - scaleFloat k x = encodeFloat m (n+k) - where (m,n) = decodeFloat x - - atan2 y x - | x > 0 = atan (y/x) - | x == 0 && y > 0 = pi/2 - | x < 0 && y > 0 = pi + atan (y/x) - |(x <= 0 && y < 0) || - (x < 0 && isNegativeZero y) || - (isNegativeZero x && isNegativeZero y) - = -atan2 (-y) x - | y == 0 && (x < 0 || isNegativeZero x) - = pi -- must be after the previous test on zero y - | x==0 && y==0 = y -- must be after the other double zero tests - | otherwise = x + y -- x or y is a NaN, return a NaN (via +) +A few small numeric functions +\begin{code} +subtract :: (Num a) => a -> a -> a +{-# INLINE subtract #-} +subtract x y = y - x + +ord_0 :: Num a => a +ord_0 = fromInt (ord '0') \end{code} + %********************************************************* %* * \subsection{Instances for @Int@} @@ -157,57 +82,228 @@ instance Num Int where | n `eqInt` 0 = 0 | otherwise = 1 - fromInteger (S# i#) = I# i# - fromInteger (J# s# d#) - = case (integer2Int# s# d#) of { i# -> I# i# } + fromInteger n = integer2Int n + fromInt n = n +\end{code} - fromInt n = n -instance Real Int where - toRational x = toInteger x % 1 +\begin{code} +-- These can't go in PrelBase with the defn of Int, because +-- we don't have pairs defined at that time! -instance Integral Int where - a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b) +quotRemInt :: Int -> Int -> (Int, Int) +a@(I# _) `quotRemInt` b@(I# _) = (a `quotInt` b, a `remInt` b) -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) - -- Following chks for zero divisor are non-standard (WDP) - a `quot` b = if b /= 0 - then a `quotInt` b - else error "Prelude.Integral.quot{Int}: divide by 0" - a `rem` b = if b /= 0 - then a `remInt` b - else error "Prelude.Integral.rem{Int}: divide by 0" - - x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y - else if x < 0 && y > 0 then quotInt (x-y+1) y - else quotInt x y - x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then - if r/=0 then r+y else 0 - else - r - where r = remInt x y - - divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y) +divModInt :: Int -> Int -> (Int, Int) +divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y) -- Stricter. Sorry if you don't like it. (WDP 94/10) +\end{code} + + +%********************************************************* +%* * +\subsection{The @Integer@ type} +%* * +%********************************************************* + +\begin{code} +data Integer + = S# Int# -- small integers + | J# Int# ByteArray# -- large integers +\end{code} + +Convenient boxed Integer PrimOps. + +\begin{code} +zeroInteger :: Integer +zeroInteger = S# 0# ---OLD: even x = eqInt (x `mod` 2) 0 ---OLD: odd x = neInt (x `mod` 2) 0 +int2Integer :: Int -> Integer +{-# INLINE int2Integer #-} +int2Integer (I# i) = S# i - toInteger (I# i) = int2Integer i -- give back a full-blown Integer - toInt x = x +integer2Int :: Integer -> Int +integer2Int (S# i) = I# i +integer2Int (J# s d) = case (integer2Int# s d) of { n# -> I# n# } +addr2Integer :: Addr# -> Integer +{-# INLINE addr2Integer #-} +addr2Integer x = case addr2Integer# x of (# s, d #) -> J# s d + +toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d } +toBig i@(J# _ _) = i \end{code} + %********************************************************* %* * -\subsection{Instances for @Integer@} +\subsection{Dividing @Integers@} %* * %********************************************************* \begin{code} -toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d } -toBig i@(J# _ _) = i +quotRemInteger :: Integer -> Integer -> (Integer, Integer) +quotRemInteger (S# i) (S# j) + = case quotRemInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j ) +quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2) +quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2 +quotRemInteger (J# s1 d1) (J# s2 d2) + = case (quotRemInteger# s1 d1 s2 d2) of + (# s3, d3, s4, d4 #) + -> (J# s3 d3, J# s4 d4) + +divModInteger (S# i) (S# j) + = case divModInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j) +divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2) +divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2 +divModInteger (J# s1 d1) (J# s2 d2) + = case (divModInteger# s1 d1 s2 d2) of + (# s3, d3, s4, d4 #) + -> (J# s3 d3, J# s4 d4) + +remInteger :: Integer -> Integer -> Integer +remInteger ia 0 + = error "Prelude.Integral.rem{Integer}: divide by 0" +remInteger (S# a) (S# b) + = S# (remInt# a b) +remInteger ia@(S# a) (J# sb b) + | sb ==# 1# = S# (remInt# a (word2Int# (integer2Word# sb b))) + | sb ==# -1# = S# (remInt# a (0# -# (word2Int# (integer2Word# sb b)))) + | 0# <# sb = ia + | otherwise = S# (0# -# a) +remInteger (J# sa a) (S# b) + = case int2Integer# b of { (# sb, b #) -> + case remInteger# sa a sb b of { (# sr, r #) -> + S# (sr *# (word2Int# (integer2Word# sr r))) }} +remInteger (J# sa a) (J# sb b) + = case remInteger# sa a sb b of (# sr, r #) -> J# sr r + +quotInteger :: Integer -> Integer -> Integer +quotInteger ia 0 + = error "Prelude.Integral.quot{Integer}: divide by 0" +quotInteger (S# a) (S# b) + = S# (quotInt# a b) +quotInteger (S# a) (J# sb b) + | sb ==# 1# = S# (quotInt# a (word2Int# (integer2Word# sb b))) + | sb ==# -1# = S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b)))) + | otherwise = zeroInteger +quotInteger (J# sa a) (S# b) + = case int2Integer# b of { (# sb, b #) -> + case quotInteger# sa a sb b of (# sq, q #) -> J# sq q } +quotInteger (J# sa a) (J# sb b) + = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g +\end{code} + + + +\begin{code} +gcdInteger :: Integer -> Integer -> Integer +gcdInteger (S# a) (S# b) + = case gcdInt# a b of g -> S# g +gcdInteger ia@(S# a) ib@(J# sb b) + | a ==# 0# = abs ib + | sb ==# 0# = abs ia + | otherwise = case gcdIntegerInt# sb b a of g -> S# g +gcdInteger ia@(J# sa a) ib@(S# b) + | sa ==# 0# = abs ib + | b ==# 0# = abs ia + | otherwise = case gcdIntegerInt# sa a b of g -> S# g +gcdInteger (J# sa a) (J# sb b) + = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g + +lcmInteger :: Integer -> Integer -> Integer +lcmInteger a 0 + = zeroInteger +lcmInteger 0 b + = zeroInteger +lcmInteger a b + = (divExact aa (gcdInteger aa ab)) * ab + where aa = abs a + ab = abs b + +divExact :: Integer -> Integer -> Integer +divExact (S# a) (S# b) + = S# (quotInt# a b) +divExact (S# a) (J# sb b) + = S# (quotInt# a (sb *# (word2Int# (integer2Word# sb b)))) +divExact (J# sa a) (S# b) + = case int2Integer# b of + (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d +divExact (J# sa a) (J# sb b) + = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d +\end{code} + + +%********************************************************* +%* * +\subsection{The @Integer@ instances for @Eq@, @Ord@} +%* * +%********************************************************* + +\begin{code} +instance Eq Integer where + (S# i) == (S# j) = i ==# j + (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0# + (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0# + (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0# + + (S# i) /= (S# j) = i /=# j + (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0# + (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0# + (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0# + +------------------------------------------------------------------------ +instance Ord Integer where + (S# i) <= (S# j) = i <=# j + (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0# + (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0# + (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0# + + (S# i) > (S# j) = i ># j + (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0# + (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0# + (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0# + + (S# i) < (S# j) = i <# j + (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0# + (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0# + (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0# + + (S# i) >= (S# j) = i >=# j + (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0# + (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0# + (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0# + + compare (S# i) (S# j) + | i ==# j = EQ + | i <=# j = LT + | otherwise = GT + compare (J# s d) (S# i) + = case cmpIntegerInt# s d i of { res# -> + if res# <# 0# then LT else + if res# ># 0# then GT else EQ + } + compare (S# i) (J# s d) + = case cmpIntegerInt# s d i of { res# -> + if res# ># 0# then LT else + if res# <# 0# then GT else EQ + } + compare (J# s1 d1) (J# s2 d2) + = case cmpInteger# s1 d1 s2 d2 of { res# -> + if res# <# 0# then LT else + if res# ># 0# then GT else EQ + } +\end{code} + + +%********************************************************* +%* * +\subsection{The @Integer@ instances for @Num@} +%* * +%********************************************************* +\begin{code} instance Num Integer where (+) i1@(S# i) i2@(S# j) = case addIntC# i j of { (# r, c #) -> @@ -258,90 +354,21 @@ instance Num Integer where fromInteger x = x fromInt (I# i) = S# i +\end{code} -instance Real Integer where - toRational x = x % 1 - -instance Integral Integer where - -- ToDo: a `rem` b returns a small integer if b is small, - -- a `quot` b returns a small integer if a is small. - quotRem (S# i) (S# j) - = case quotRem (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j) - quotRem i1@(J# _ _) i2@(S# _) = quotRem i1 (toBig i2) - quotRem i1@(S# _) i2@(J# _ _) = quotRem (toBig i1) i2 - quotRem (J# s1 d1) (J# s2 d2) - = case (quotRemInteger# s1 d1 s2 d2) of - (# s3, d3, s4, d4 #) - -> (J# s3 d3, J# s4 d4) - - toInteger n = n - toInt (S# i) = I# i - toInt (J# s d) = case (integer2Int# s d) of { n# -> I# n# } - - -- we've got specialised quot/rem methods for Integer (see below) - n `quot` d = n `quotInteger` d - n `rem` d = n `remInteger` d - - n `div` d = q where (q,_) = divMod n d - n `mod` d = r where (_,r) = divMod n d - - divMod (S# i) (S# j) - = case divMod (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j) - divMod i1@(J# _ _) i2@(S# _) = divMod i1 (toBig i2) - divMod i1@(S# _) i2@(J# _ _) = divMod (toBig i1) i2 - divMod (J# s1 d1) (J# s2 d2) - = case (divModInteger# s1 d1 s2 d2) of - (# s3, d3, s4, d4 #) - -> (J# s3 d3, J# s4 d4) - -remInteger :: Integer -> Integer -> Integer -remInteger ia 0 - = error "Prelude.Integral.rem{Integer}: divide by 0" -remInteger (S# a) (S# b) = S# (remInt# a b) -remInteger ia@(S# a) (J# sb b) - = if sb ==# 1# - then - S# (remInt# a (word2Int# (integer2Word# sb b))) - else if sb ==# -1# then - S# (remInt# a (0# -# (word2Int# (integer2Word# sb b)))) - else if 0# <# sb then - ia - else - S# (0# -# a) -remInteger (J# sa a) (S# b) - = case int2Integer# b of { (# sb, b #) -> - case remInteger# sa a sb b of { (# sr, r #) -> - S# (sr *# (word2Int# (integer2Word# sr r))) }} -remInteger (J# sa a) (J# sb b) - = case remInteger# sa a sb b of (# sr, r #) -> J# sr r - -quotInteger :: Integer -> Integer -> Integer -quotInteger ia 0 - = error "Prelude.Integral.quot{Integer}: divide by 0" -quotInteger (S# a) (S# b) = S# (quotInt# a b) -quotInteger (S# a) (J# sb b) - = if sb ==# 1# - then - S# (quotInt# a (word2Int# (integer2Word# sb b))) - else if sb ==# -1# then - S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b)))) - else - zeroInteger -quotInteger (J# sa a) (S# b) - = case int2Integer# b of { (# sb, b #) -> - case quotInteger# sa a sb b of (# sq, q #) -> J# sq q } -quotInteger (J# sa a) (J# sb b) - = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g -zeroInteger :: Integer -zeroInteger = S# 0# +%********************************************************* +%* * +\subsection{The @Integer@ instance for @Enum@} +%* * +%********************************************************* ------------------------------------------------------------------------- +\begin{code} instance Enum Integer where succ x = x + 1 pred x = x - 1 - toEnum n = toInteger n - fromEnum n = toInt n + toEnum n = int2Integer n + fromEnum n = integer2Int n {-# INLINE enumFrom #-} {-# INLINE enumFromThen #-} @@ -390,9 +417,10 @@ dn_list x delta lim = go (x::Integer) #-} \end{code} + %********************************************************* %* * -\subsection{Show code for Integers} +\subsection{The @Integer@ instances for @Show@} %* * %********************************************************* @@ -414,147 +442,7 @@ jtos i rs jtos' :: Integer -> String -> String jtos' n cs | n < 10 = chr (fromInteger n + (ord_0::Int)) : cs - | otherwise = jtos' q (chr (toInt r + (ord_0::Int)) : cs) + | otherwise = jtos' q (chr (integer2Int r + (ord_0::Int)) : cs) where - (q,r) = n `quotRem` 10 - -ord_0 :: Num a => a -ord_0 = fromInt (ord '0') -\end{code} - -%********************************************************* -%* * -\subsection{The @Ratio@ and @Rational@ types} -%* * -%********************************************************* - -\begin{code} -data (Integral a) => Ratio a = !a :% !a deriving (Eq) -type Rational = Ratio Integer - -{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-} -(%) :: (Integral a) => a -> a -> Ratio a -numerator, denominator :: (Integral a) => Ratio a -> a -\end{code} - -\tr{reduce} is a subsidiary function used only in this module . -It normalises a ratio by dividing both numerator and denominator by -their greatest common divisor. - -\begin{code} -reduce :: (Integral a) => a -> a -> Ratio a -reduce _ 0 = error "Ratio.%: zero denominator" -reduce x y = (x `quot` d) :% (y `quot` d) - where d = gcd x y -\end{code} - -\begin{code} -x % y = reduce (x * signum y) (abs y) - -numerator (x :% _) = x -denominator (_ :% y) = y - -\end{code} - -%********************************************************* -%* * -\subsection{Overloaded numeric functions} -%* * -%********************************************************* - -\begin{code} - -{-# SPECIALISE subtract :: Int -> Int -> Int #-} -subtract :: (Num a) => a -> a -> a -subtract x y = y - x - -even, odd :: (Integral a) => a -> Bool -even n = n `rem` 2 == 0 -odd = not . even - -gcd :: (Integral a) => a -> a -> a -gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" -gcd x y = gcd' (abs x) (abs y) - where gcd' a 0 = a - gcd' a b = gcd' b (a `rem` b) - -{-# SPECIALISE lcm :: - Int -> Int -> Int, - Integer -> Integer -> Integer #-} -lcm :: (Integral a) => a -> a -> a -lcm _ 0 = 0 -lcm 0 _ = 0 -lcm x y = abs ((x `quot` (gcd x y)) * y) - -{-# SPECIALISE (^) :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -(^) :: (Num a, Integral b) => a -> b -> a -_ ^ 0 = 1 -x ^ n | n > 0 = f x (n-1) x - where f _ 0 y = y - f a d y = g a d where - g b i | even i = g (b*b) (i `quot` 2) - | otherwise = f b (i-1) (b*y) -_ ^ _ = error "Prelude.^: negative exponent" - -{- SPECIALISE (^^) :: - Double -> Int -> Double, - Rational -> Int -> Rational #-} -(^^) :: (Fractional a, Integral b) => a -> b -> a -x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) -\end{code} - -%********************************************************* -%* * -\subsection{Specialized versions of gcd/lcm for Int/Integer} -%* * -%********************************************************* - -\begin{code} -{-# RULES -"Int.gcd" forall a b . gcd a b = gcdInt a b -"Integer.gcd" forall a b . gcd a b = gcdInteger a b -"Integer.lcm" forall a b . lcm a b = lcmInteger a b - #-} - -gcdInt :: Int -> Int -> Int -gcdInt (I# a) (I# b) - = I# (gcdInt# a b) - -gcdInteger :: Integer -> Integer -> Integer -gcdInteger (S# a) (S# b) - = case gcdInt# a b of g -> S# g -gcdInteger ia@(S# a) ib@(J# sb b) - | a ==# 0# = abs ib - | sb ==# 0# = abs ia - | otherwise = case gcdIntegerInt# sb b a of g -> S# g -gcdInteger ia@(J# sa a) ib@(S# b) - | sa ==# 0# = abs ib - | b ==# 0# = abs ia - | otherwise = case gcdIntegerInt# sa a b of g -> S# g -gcdInteger (J# sa a) (J# sb b) - = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g - -lcmInteger :: Integer -> Integer -> Integer -lcmInteger a 0 - = zeroInteger -lcmInteger 0 b - = zeroInteger -lcmInteger a b - = (divExact aa (gcdInteger aa ab)) * ab - where aa = abs a - ab = abs b - -divExact :: Integer -> Integer -> Integer -divExact (S# a) (S# b) - = S# (quotInt# a b) -divExact (S# a) (J# sb b) - = S# (quotInt# a (sb *# (word2Int# (integer2Word# sb b)))) -divExact (J# sa a) (S# b) - = case int2Integer# b of - (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d -divExact (J# sa a) (J# sb b) - = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d + (q,r) = n `quotRemInteger` 10 \end{code} diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs index 6351fca9b6..187d2a7bce 100644 --- a/ghc/lib/std/PrelPack.lhs +++ b/ghc/lib/std/PrelPack.lhs @@ -53,6 +53,7 @@ import PrelList ( length ) import PrelST import PrelNum import PrelArr +import PrelByteArr import PrelAddr \end{code} diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs index 6c8da898ff..ad3fe8161c 100644 --- a/ghc/lib/std/PrelRead.lhs +++ b/ghc/lib/std/PrelRead.lhs @@ -14,7 +14,8 @@ module PrelRead where import PrelErr ( error ) import PrelEnum ( Enum(..) ) import PrelNum -import PrelNumExtra +import PrelReal +import PrelFloat import PrelList import PrelTup import PrelMaybe diff --git a/ghc/lib/std/PrelReal.lhs b/ghc/lib/std/PrelReal.lhs new file mode 100644 index 0000000000..530f12306c --- /dev/null +++ b/ghc/lib/std/PrelReal.lhs @@ -0,0 +1,299 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelReal]{Module @PrelReal@} + +The types + + Ratio, Rational + +and the classes + + Real + Integral + Fractional + RealFrac + + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelReal where + +import {-# SOURCE #-} PrelErr +import PrelBase +import PrelNum +import PrelList +import PrelEnum +import PrelShow + +infixr 8 ^, ^^ +infixl 7 /, `quot`, `rem`, `div`, `mod` + +default () -- Double isn't available yet, + -- and we shouldn't be using defaults anyway +\end{code} + + +%********************************************************* +%* * +\subsection{The @Ratio@ and @Rational@ types} +%* * +%********************************************************* + +\begin{code} +data (Integral a) => Ratio a = !a :% !a deriving (Eq) +type Rational = Ratio Integer +\end{code} + + +\begin{code} +{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-} +(%) :: (Integral a) => a -> a -> Ratio a +numerator, denominator :: (Integral a) => Ratio a -> a +\end{code} + +\tr{reduce} is a subsidiary function used only in this module . +It normalises a ratio by dividing both numerator and denominator by +their greatest common divisor. + +\begin{code} +reduce :: (Integral a) => a -> a -> Ratio a +reduce _ 0 = error "Ratio.%: zero denominator" +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y +\end{code} + +\begin{code} +x % y = reduce (x * signum y) (abs y) + +numerator (x :% _) = x +denominator (_ :% y) = y +\end{code} + + +%********************************************************* +%* * +\subsection{Standard numeric classes} +%* * +%********************************************************* + +\begin{code} +class (Num a, Ord a) => Real a where + toRational :: a -> Rational + +class (Real a, Enum a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + toInteger :: a -> Integer + toInt :: a -> Int -- partain: Glasgow extension + + n `quot` d = q where (q,_) = quotRem n d + n `rem` d = r where (_,r) = quotRem n d + n `div` d = q where (q,_) = divMod n d + n `mod` d = r where (_,r) = divMod n d + divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + + recip x = 1 / x + x / y = x * recip y + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x +\end{code} + + +%********************************************************* +%* * +\subsection{Instances for @Int@} +%* * +%********************************************************* + +\begin{code} +instance Real Int where + toRational x = toInteger x % 1 + +instance Integral Int where + toInteger i = int2Integer i -- give back a full-blown Integer + toInt x = x + + -- Following chks for zero divisor are non-standard (WDP) + a `quot` b = if b /= 0 + then a `quotInt` b + else error "Prelude.Integral.quot{Int}: divide by 0" + a `rem` b = if b /= 0 + then a `remInt` b + else error "Prelude.Integral.rem{Int}: divide by 0" + + x `div` y = x `divInt` y + x `mod` y = x `modInt` y + + a `quotRem` b = a `quotRemInt` b + a `divMod` b = a `divModInt` b +\end{code} + + +%********************************************************* +%* * +\subsection{Instances for @Integer@} +%* * +%********************************************************* + +\begin{code} +instance Real Integer where + toRational x = x % 1 + +instance Integral Integer where + toInteger n = n + toInt n = integer2Int n + + n `quot` d = n `quotInteger` d + n `rem` d = n `remInteger` d + + n `div` d = q where (q,_) = divMod n d + n `mod` d = r where (_,r) = divMod n d + + a `divMod` b = a `divModInteger` b + a `quotRem` b = a `quotRemInteger` b +\end{code} + + +%********************************************************* +%* * +\subsection{Instances for @Ratio@} +%* * +%********************************************************* + +\begin{code} +instance (Integral a) => Ord (Ratio a) where + (x:%y) <= (x':%y') = x * y' <= x' * y + (x:%y) < (x':%y') = x * y' < x' * y + +instance (Integral a) => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x * x') (y * y') + negate (x:%y) = (-x) :% y + abs (x:%y) = abs x :% y + signum (x:%_) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + +instance (Integral a) => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + +instance (Integral a) => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance (Integral a) => RealFrac (Ratio a) where + properFraction (x:%y) = (fromInteger (toInteger q), r:%y) + where (q,r) = quotRem x y + +instance (Integral a) => Show (Ratio a) where + showsPrec p (x:%y) = showParen (p > ratio_prec) + (shows x . showString " % " . shows y) + +ratio_prec :: Int +ratio_prec = 7 + +instance (Integral a) => Enum (Ratio a) where + succ x = x + 1 + pred x = x - 1 + + toEnum n = fromInt n :% 1 + fromEnum = fromInteger . truncate + + enumFrom = bounded_iterator True (1) + enumFromThen n m = bounded_iterator (diff >= 0) diff n + where diff = m - n + +bounded_iterator :: (Ord a, Num a) => Bool -> a -> a -> [a] +bounded_iterator inc step v + | inc && v > new_v = [v] -- oflow + | not inc && v < new_v = [v] -- uflow + | otherwise = v : bounded_iterator inc step new_v + where + new_v = v + step +\end{code} + + +%********************************************************* +%* * +\subsection{Overloaded numeric functions} +%* * +%********************************************************* + +\begin{code} +showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x + | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x)) + | otherwise = showPos x + +even, odd :: (Integral a) => a -> Bool +even n = n `rem` 2 == 0 +odd = not . even + +------------------------------------------------------- +{-# SPECIALISE (^) :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +(^) :: (Num a, Integral b) => a -> b -> a +_ ^ 0 = 1 +x ^ n | n > 0 = f x (n-1) x + where f _ 0 y = y + f a d y = g a d where + g b i | even i = g (b*b) (i `quot` 2) + | otherwise = f b (i-1) (b*y) +_ ^ _ = error "Prelude.^: negative exponent" + +{- SPECIALISE (^^) :: + Rational -> Int -> Rational #-} +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) + + +------------------------------------------------------- +gcd :: (Integral a) => a -> a -> a +gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' a 0 = a + gcd' a b = gcd' b (a `rem` b) + +lcm :: (Integral a) => a -> a -> a +{-# SPECIALISE lcm :: Int -> Int -> Int #-} +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` (gcd x y)) * y) + + +{-# RULES +"Int.gcd" forall a b . gcd a b = gcdInt a b +"Integer.gcd" forall a b . gcd a b = gcdInteger a b +"Integer.lcm" forall a b . lcm a b = lcmInteger a b + #-} +\end{code} diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs index 1aca5bcbab..b41c0795e1 100644 --- a/ghc/lib/std/PrelST.lhs +++ b/ghc/lib/std/PrelST.lhs @@ -13,6 +13,8 @@ import PrelShow import PrelBase import PrelGHC import PrelNum () -- So that we get the .hi file for system imports + +default () \end{code} %********************************************************* diff --git a/ghc/lib/std/PrelStable.lhs b/ghc/lib/std/PrelStable.lhs index fb121584d5..faefb0395b 100644 --- a/ghc/lib/std/PrelStable.lhs +++ b/ghc/lib/std/PrelStable.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelStable.lhs,v 1.2 1999/09/19 19:12:42 sof Exp $ +% $Id: PrelStable.lhs,v 1.3 1999/12/20 10:34:35 simonpj Exp $ % % (c) The GHC Team, 1992-1999 % @@ -23,7 +23,6 @@ import PrelIOBase data StablePtr a = StablePtr (StablePtr# a) instance CCallable (StablePtr a) -instance CCallable (StablePtr# a) instance CReturnable (StablePtr a) makeStablePtr :: a -> IO (StablePtr a) diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs index 34dbfa88f1..b1f143a394 100644 --- a/ghc/lib/std/PrelTup.lhs +++ b/ghc/lib/std/PrelTup.lhs @@ -13,6 +13,8 @@ module PrelTup where import {-# SOURCE #-} PrelErr ( error ) import PrelBase + +default () -- Double isn't available yet \end{code} diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs index 0b9f102379..01e82b3ae4 100644 --- a/ghc/lib/std/Prelude.lhs +++ b/ghc/lib/std/Prelude.lhs @@ -77,7 +77,8 @@ import PrelList import PrelRead import PrelEnum import PrelNum -import PrelNumExtra +import PrelReal +import PrelFloat import PrelTup import PrelMaybe import PrelShow @@ -101,6 +102,12 @@ undefined = error "Prelude.undefined" \end{code} +%********************************************************* +%* * +\subsection{List sum and product} +%* * +%********************************************************* + List sum and product are defined here because PrelList is too far down the compilation chain to "see" the Num class. @@ -125,3 +132,39 @@ product l = prod l 1 prod (x:xs) a = prod xs (a*x) #endif \end{code} + + +%********************************************************* +%* * +\subsection{Coercions} +%* * +%********************************************************* + +\begin{code} +{-# SPECIALIZE fromIntegral :: + Int -> Rational, + Integer -> Rational, + Int -> Int, + Int -> Integer, + Int -> Float, + Int -> Double, + Integer -> Int, + Integer -> Integer, + Integer -> Float, + Integer -> Double #-} +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +{-# SPECIALIZE realToFrac :: + Double -> Rational, + Rational -> Double, + Float -> Rational, + Rational -> Float, + Rational -> Rational, + Double -> Double, + Double -> Float, + Float -> Float, + Float -> Double #-} +realToFrac :: (Real a, Fractional b) => a -> b +realToFrac = fromRational . toRational +\end{code} diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs index 9bf845e0bc..09ba145892 100644 --- a/ghc/lib/std/Random.lhs +++ b/ghc/lib/std/Random.lhs @@ -29,17 +29,18 @@ module Random ) where #ifndef __HUGS__ -import CPUTime (getCPUTime) -import PrelST -import PrelRead -import PrelShow -import PrelNum -- So we get fromInt, toInt -import PrelIOBase -import PrelNumExtra ( float2Double, double2Float ) -import PrelBase -import PrelArr -import Time (getClockTime, ClockTime(..)) +import PrelGHC ( RealWorld ) +import PrelNum ( fromInt ) +import PrelShow ( showSignedInt, showSpace ) +import PrelRead ( readDec ) +import PrelIOBase ( unsafePerformIO, stToIO ) +import PrelArr ( MutableVar, newVar, readVar, writeVar ) +import PrelReal ( toInt ) +import CPUTime ( getCPUTime ) +import PrelFloat ( float2Double, double2Float ) +import Time ( getClockTime, ClockTime(..) ) #endif + import Char ( isSpace, chr, ord ) \end{code} diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs index a002888ab1..f7593ab775 100644 --- a/ghc/lib/std/Ratio.lhs +++ b/ghc/lib/std/Ratio.lhs @@ -7,8 +7,6 @@ Standard functions on rational numbers \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - module Ratio ( Ratio , Rational @@ -31,9 +29,59 @@ module Ratio -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +\end{code} + #ifndef __HUGS__ -import PrelNum -import PrelNumExtra -#endif + +\begin{code} +import Prelude -- To generate the dependencies +import PrelReal -- The basic defns for Ratio +\end{code} + +%********************************************************* +%* * +\subsection{approxRational} +%* * +%********************************************************* + +@approxRational@, applied to two real fractional numbers x and epsilon, +returns the simplest rational number within epsilon of x. A rational +number n%d in reduced form is said to be simpler than another n'%d' if +abs n <= abs n' && d <= d'. Any real interval contains a unique +simplest rational; here, for simplicity, we assume a closed rational +interval. If such an interval includes at least one whole number, then +the simplest rational is the absolutely least whole number. Otherwise, +the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +and abs r' < d', and the simplest rational is q%1 + the reciprocal of +the simplest rational between d'%r' and d%r. + +\begin{code} +approxRational :: (RealFrac a) => a -> a -> Rational +approxRational rat eps = simplest (rat-eps) (rat+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' \end{code} + + +#endif + diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index e62b7d4311..41373d1934 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -25,7 +25,7 @@ import Prelude import PrelAddr import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) import PrelPack ( unpackCString, unpackCStringST, packString ) -import PrelArr ( ByteArray ) +import PrelByteArr ( ByteArray ) type PrimByteArray = ByteArray Int diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs index d9a336f4ae..ff8556a085 100644 --- a/ghc/lib/std/Time.lhs +++ b/ghc/lib/std/Time.lhs @@ -38,17 +38,21 @@ module Time #ifdef __HUGS__ import PreludeBuiltin #else -import PrelBase -import PrelShow -import PrelIOBase -import PrelHandle -import PrelArr -import PrelST -import PrelAddr -import PrelNum -import PrelPack ( unpackCString, new_ps_array, - freeze_ps_array, unpackCStringBA +import PrelGHC ( RealWorld, (>#), (<#), (==#), + newIntArray#, readIntArray#, + unsafeFreezeByteArray#, + int2Integer#, negateInt# ) +import PrelBase ( Int(..) ) +import PrelNum ( Integer(..), fromInt ) +import PrelIOBase ( IO(..), unsafePerformIO, stToIO, constructErrorAndFail ) +import PrelShow ( showList__ ) +import PrelPack ( unpackCString, unpackCStringBA, + new_ps_array, freeze_ps_array ) +import PrelByteArr ( MutableByteArray(..) ) +import PrelHandle ( Bytes ) +import PrelAddr ( Addr ) + #endif import Ix |