base: Manually unlit .lhs into .hs modules

This commit mostly converts literate comments into ordinary
Haskell comments or sometimes even Haddock comments, while also
removing literate comments in a few cases where they don't make
much sense anymore.

Moreover, in a few cases trailing whitespaces were removed as well.

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D456

1 files changed, 1153 insertions, 0 deletions

diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs
new file mode 100644
index 0000000000..74d7cb8f01
--- /dev/null
+++ b/libraries/base/GHC/Float.hs
@@ -0,0 +1,1153 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , MagicHash
+           , UnboxedTuples
+  #-}
+-- We believe we could deorphan this module, by moving lots of things
+-- around, but we haven't got there yet:
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Float
+-- Copyright   :  (c) The University of Glasgow 1994-2002
+--                Portions obtained from hbc (c) Lennart Augusstson
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- The types 'Float' and 'Double', and the classes 'Floating' and 'RealFloat'.
+--
+-----------------------------------------------------------------------------
+
+#include "ieee-flpt.h"
+
+module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double#
+                , double2Int, int2Double, float2Int, int2Float )
+    where
+
+import Data.Maybe
+
+import Data.Bits
+import GHC.Base
+import GHC.List
+import GHC.Enum
+import GHC.Show
+import GHC.Num
+import GHC.Real
+import GHC.Arr
+import GHC.Float.RealFracMethods
+import GHC.Float.ConversionUtils
+import GHC.Integer.Logarithms ( integerLogBase# )
+import GHC.Integer.Logarithms.Internals
+
+infixr 8  **
+
+------------------------------------------------------------------------
+-- Standard numeric classes
+------------------------------------------------------------------------
+
+-- | Trigonometric and hyperbolic functions and related functions.
+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
+
+    {-# INLINE (**) #-}
+    {-# INLINE logBase #-}
+    {-# INLINE sqrt #-}
+    {-# INLINE tan #-}
+    {-# INLINE tanh #-}
+    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
+
+-- | Efficient, machine-independent access to the components of a
+-- floating-point number.
+class  (RealFrac a, Floating a) => RealFloat a  where
+    -- | a constant function, returning the radix of the representation
+    -- (often @2@)
+    floatRadix          :: a -> Integer
+    -- | a constant function, returning the number of digits of
+    -- 'floatRadix' in the significand
+    floatDigits         :: a -> Int
+    -- | a constant function, returning the lowest and highest values
+    -- the exponent may assume
+    floatRange          :: a -> (Int,Int)
+    -- | The function 'decodeFloat' applied to a real floating-point
+    -- number returns the significand expressed as an 'Integer' and an
+    -- appropriately scaled exponent (an 'Int').  If @'decodeFloat' x@
+    -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@
+    -- is the floating-point radix, and furthermore, either @m@ and @n@
+    -- are both zero or else @b^(d-1) <= 'abs' m < b^d@, where @d@ is
+    -- the value of @'floatDigits' x@.
+    -- In particular, @'decodeFloat' 0 = (0,0)@. If the type
+    -- contains a negative zero, also @'decodeFloat' (-0.0) = (0,0)@.
+    -- /The result of/ @'decodeFloat' x@ /is unspecified if either of/
+    -- @'isNaN' x@ /or/ @'isInfinite' x@ /is/ 'True'.
+    decodeFloat         :: a -> (Integer,Int)
+    -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the
+    -- sense that for finite @x@ with the exception of @-0.0@,
+    -- @'uncurry' 'encodeFloat' ('decodeFloat' x) = x@.
+    -- @'encodeFloat' m n@ is one of the two closest representable
+    -- floating-point numbers to @m*b^^n@ (or @&#177;Infinity@ if overflow
+    -- occurs); usually the closer, but if @m@ contains too many bits,
+    -- the result may be rounded in the wrong direction.
+    encodeFloat         :: Integer -> Int -> a
+    -- | 'exponent' corresponds to the second component of 'decodeFloat'.
+    -- @'exponent' 0 = 0@ and for finite nonzero @x@,
+    -- @'exponent' x = snd ('decodeFloat' x) + 'floatDigits' x@.
+    -- If @x@ is a finite floating-point number, it is equal in value to
+    -- @'significand' x * b ^^ 'exponent' x@, where @b@ is the
+    -- floating-point radix.
+    -- The behaviour is unspecified on infinite or @NaN@ values.
+    exponent            :: a -> Int
+    -- | The first component of 'decodeFloat', scaled to lie in the open
+    -- interval (@-1@,@1@), either @0.0@ or of absolute value @>= 1\/b@,
+    -- where @b@ is the floating-point radix.
+    -- The behaviour is unspecified on infinite or @NaN@ values.
+    significand         :: a -> a
+    -- | multiplies a floating-point number by an integer power of the radix
+    scaleFloat          :: Int -> a -> a
+    -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value
+    isNaN               :: a -> Bool
+    -- | 'True' if the argument is an IEEE infinity or negative infinity
+    isInfinite          :: a -> Bool
+    -- | 'True' if the argument is too small to be represented in
+    -- normalized format
+    isDenormalized      :: a -> Bool
+    -- | 'True' if the argument is an IEEE negative zero
+    isNegativeZero      :: a -> Bool
+    -- | 'True' if the argument is an IEEE floating point number
+    isIEEE              :: a -> Bool
+    -- | a version of arctangent taking two real floating-point arguments.
+    -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle
+    -- (from the positive x-axis) of the vector from the origin to the
+    -- point @(x,y)@.  @'atan2' y x@ returns a value in the range [@-pi@,
+    -- @pi@].  It follows the Common Lisp semantics for the origin when
+    -- signed zeroes are supported.  @'atan2' y 1@, with @y@ in a type
+    -- that is 'RealFloat', should return the same value as @'atan' y@.
+    -- A default definition of 'atan2' is provided, but implementors
+    -- can provide a more accurate implementation.
+    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 0 x      =  x
+    scaleFloat k x
+      | isFix           =  x
+      | otherwise       =  encodeFloat m (n + clamp b k)
+                           where (m,n) = decodeFloat x
+                                 (l,h) = floatRange x
+                                 d     = floatDigits x
+                                 b     = h - l + 4*d
+                                 -- n+k may overflow, which would lead
+                                 -- to wrong results, hence we clamp the
+                                 -- scaling parameter.
+                                 -- If n + k would be larger than h,
+                                 -- n + clamp b k must be too, simliar
+                                 -- for smaller than l - d.
+                                 -- Add a little extra to keep clear
+                                 -- from the boundary cases.
+                                 isFix = x == 0 || isNaN x || isInfinite 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 +)
+
+------------------------------------------------------------------------
+-- Float
+------------------------------------------------------------------------
+
+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 -- handles (-0.0)
+             | x >  0    = x
+             | otherwise = negateFloat x
+    signum x | x > 0     = 1
+             | x < 0     = negateFloat 1
+             | otherwise = x -- handles 0.0, (-0.0), and NaN
+
+    {-# INLINE fromInteger #-}
+    fromInteger i = F# (floatFromInteger i)
+
+instance  Real Float  where
+    toRational (F# x#)  =
+        case decodeFloat_Int# x# of
+          (# m#, e# #)
+            | isTrue# (e# >=# 0#)                               ->
+                    (smallInteger m# `shiftLInteger` e#) :% 1
+            | isTrue# ((int2Word# m# `and#` 1##) `eqWord#` 0##) ->
+                    case elimZerosInt# m# (negateInt# e#) of
+                      (# n, d# #) -> n :% shiftLInteger 1 d#
+            | otherwise                                         ->
+                    smallInteger m# :% shiftLInteger 1 (negateInt# e#)
+
+instance  Fractional Float  where
+    (/) x y             =  divideFloat x y
+    {-# INLINE fromRational #-}
+    fromRational (n:%d) = rationalToFloat n d
+    recip x             =  1.0 / x
+
+rationalToFloat :: Integer -> Integer -> Float
+{-# NOINLINE [1] rationalToFloat #-}
+rationalToFloat n 0
+    | n == 0        = 0/0
+    | n < 0         = (-1)/0
+    | otherwise     = 1/0
+rationalToFloat n d
+    | n == 0        = encodeFloat 0 0
+    | n < 0         = -(fromRat'' minEx mantDigs (-n) d)
+    | otherwise     = fromRat'' minEx mantDigs n d
+      where
+        minEx       = FLT_MIN_EXP
+        mantDigs    = FLT_MANT_DIG
+
+-- RULES for Integer and Int
+{-# RULES
+"properFraction/Float->Integer"     properFraction = properFractionFloatInteger
+"truncate/Float->Integer"           truncate = truncateFloatInteger
+"floor/Float->Integer"              floor = floorFloatInteger
+"ceiling/Float->Integer"            ceiling = ceilingFloatInteger
+"round/Float->Integer"              round = roundFloatInteger
+"properFraction/Float->Int"         properFraction = properFractionFloatInt
+"truncate/Float->Int"               truncate = float2Int
+"floor/Float->Int"                  floor = floorFloatInt
+"ceiling/Float->Int"                ceiling = ceilingFloatInt
+"round/Float->Int"                  round = roundFloatInt
+  #-}
+instance  RealFrac Float  where
+
+        -- ceiling, floor, and truncate are all small
+    {-# INLINE [1] ceiling #-}
+    {-# INLINE [1] floor #-}
+    {-# INLINE [1] truncate #-}
+
+-- We assume that FLT_RADIX is 2 so that we can use more efficient code
+#if FLT_RADIX != 2
+#error FLT_RADIX must be 2
+#endif
+    properFraction (F# x#)
+      = case decodeFloat_Int# x# of
+        (# m#, n# #) ->
+            let m = I# m#
+                n = I# n#
+            in
+            if n >= 0
+            then (fromIntegral m * (2 ^ n), 0.0)
+            else let i = if m >= 0 then                m `shiftR` negate n
+                                   else negate (negate m `shiftR` negate n)
+                     f = m - (i `shiftL` negate n)
+                 in (fromIntegral i, encodeFloat (fromIntegral f) 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 = 0.5 * log ((1.0+x) / (1.0-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_Int# f# of
+                          (# i, e #) -> (smallInteger i, I# e)
+
+    encodeFloat i (I# e) = F# (encodeFloatInteger i 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 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
+                            (m,n) -> encodeFloat m (n + clamp bf k)
+                        where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG
+                              isFix = x == 0 || isFloatFinite x == 0
+
+    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 = showSignedFloat showFloat x
+    showList = showList__ (showsPrec 0)
+
+------------------------------------------------------------------------
+-- Double
+------------------------------------------------------------------------
+
+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 -- handles (-0.0)
+             | x >  0    = x
+             | otherwise = negateDouble x
+    signum x | x > 0     = 1
+             | x < 0     = negateDouble 1
+             | otherwise = x -- handles 0.0, (-0.0), and NaN
+
+
+    {-# INLINE fromInteger #-}
+    fromInteger i = D# (doubleFromInteger i)
+
+
+instance  Real Double  where
+    toRational (D# x#)  =
+        case decodeDoubleInteger x# of
+          (# m, e# #)
+            | isTrue# (e# >=# 0#)                                  ->
+                shiftLInteger m e# :% 1
+            | isTrue# ((integerToWord m `and#` 1##) `eqWord#` 0##) ->
+                case elimZerosInteger m (negateInt# e#) of
+                    (# n, d# #) ->  n :% shiftLInteger 1 d#
+            | otherwise                                            ->
+                m :% shiftLInteger 1 (negateInt# e#)
+
+instance  Fractional Double  where
+    (/) x y             =  divideDouble x y
+    {-# INLINE fromRational #-}
+    fromRational (n:%d) = rationalToDouble n d
+    recip x             =  1.0 / x
+
+rationalToDouble :: Integer -> Integer -> Double
+{-# NOINLINE [1] rationalToDouble #-}
+rationalToDouble n 0
+    | n == 0        = 0/0
+    | n < 0         = (-1)/0
+    | otherwise     = 1/0
+rationalToDouble n d
+    | n == 0        = encodeFloat 0 0
+    | n < 0         = -(fromRat'' minEx mantDigs (-n) d)
+    | otherwise     = fromRat'' minEx mantDigs n d
+      where
+        minEx       = DBL_MIN_EXP
+        mantDigs    = DBL_MANT_DIG
+
+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 = 0.5 * log ((1.0+x) / (1.0-x))
+
+-- RULES for Integer and Int
+{-# RULES
+"properFraction/Double->Integer"    properFraction = properFractionDoubleInteger
+"truncate/Double->Integer"          truncate = truncateDoubleInteger
+"floor/Double->Integer"             floor = floorDoubleInteger
+"ceiling/Double->Integer"           ceiling = ceilingDoubleInteger
+"round/Double->Integer"             round = roundDoubleInteger
+"properFraction/Double->Int"        properFraction = properFractionDoubleInt
+"truncate/Double->Int"              truncate = double2Int
+"floor/Double->Int"                 floor = floorDoubleInt
+"ceiling/Double->Int"               ceiling = ceilingDoubleInt
+"round/Double->Int"                 round = roundDoubleInt
+  #-}
+instance  RealFrac Double  where
+
+        -- ceiling, floor, and truncate are all small
+    {-# INLINE [1] ceiling #-}
+    {-# INLINE [1] floor #-}
+    {-# INLINE [1] truncate #-}
+
+    properFraction x
+      = case (decodeFloat x)      of { (m,n) ->
+        if n >= 0 then
+            (fromInteger m * 2 ^ n, 0.0)
+        else
+            case (quotRem m (2^(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 decodeDoubleInteger x#   of
+          (# i, j #) -> (i, I# j)
+
+    encodeFloat i (I# j) = D# (encodeDoubleInteger i j)
+
+    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 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
+                            (m,n) -> encodeFloat m (n + clamp bd k)
+                        where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG
+                              isFix = x == 0 || isDoubleFinite x == 0
+
+    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 = showSignedFloat showFloat x
+    showList = showList__ (showsPrec 0)
+
+
+------------------------------------------------------------------------
+-- 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.)
+-}
+
+instance  Enum Float  where
+    succ x         = x + 1
+    pred x         = x - 1
+    toEnum         = int2Float
+    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         =  int2Double
+    fromEnum       =  fromInteger . truncate   -- may overflow
+    enumFrom       =  numericEnumFrom
+    enumFromTo     =  numericEnumFromTo
+    enumFromThen   =  numericEnumFromThen
+    enumFromThenTo =  numericEnumFromThenTo
+
+------------------------------------------------------------------------
+-- Printing floating point
+------------------------------------------------------------------------
+
+-- | Show a signed 'RealFloat' value to full precision
+-- using standard decimal notation for arguments whose absolute value lies
+-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
+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
+
+-- This is just a compatibility stub, as the "alt" argument formerly
+-- didn't exist.
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = formatRealFloatAlt fmt decs False x
+
+formatRealFloatAlt :: (RealFloat a) => FFFormat -> Maybe Int -> Bool -> a
+                 -> String
+formatRealFloatAlt fmt decs alt 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'
+          []      -> error "formatRealFloat/doFmt/FFExponent: []"
+       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
+          | e <= 0    -> "0." ++ replicate (-e) '0' ++ ds
+          | otherwise ->
+             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 && not alt 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 : (if null ds' && not alt then "" else '.':ds')
+
+
+roundTo :: Int -> Int -> [Int] -> (Int,[Int])
+roundTo base d is =
+  case f d True is of
+    x@(0,_) -> x
+    (1,xs)  -> (1, 1:xs)
+    _       -> error "roundTo: bad Value"
+ where
+  b2 = base `quot` 2
+
+  f n _ []     = (0, replicate n 0)
+  f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, [])   -- Round to even when at exactly half the base
+               | otherwise = (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) (even i) 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.
+
+-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
+-- and returns a list of digits and an exponent.
+-- In particular, if @x>=0@, and
+--
+-- > floatToDigits base x = ([d1,d2,...,dn], e)
+--
+-- then
+--
+--      (1) @n >= 1@
+--
+--      (2) @x = 0.d1d2...dn * (base**e)@
+--
+--      (3) @0 <= di <= base-1@
+
+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 `quot` (expt b n), e0+n) else (f0, e0)
+  (r, s, mUp, mDn) =
+   if e >= 0 then
+    let be = expt b e in
+    if f == expt b (p-1) then
+      (f*be*b*2, 2*b, be*b, be)     -- according to Burger and Dybvig
+    else
+      (f*be*2, 2, be, be)
+   else
+    if e > minExp && f == expt b (p-1) then
+      (f*b*2, expt b (-e+1)*2, b, 1)
+    else
+      (f*2, expt b (-e)*2, 1, 1)
+  k :: Int
+  k =
+   let
+    k0 :: Int
+    k0 =
+     if b == 2 && base == 10 then
+        -- logBase 10 2 is very slightly larger than 8651/28738
+        -- (about 5.3558e-10), so if log x >= 0, the approximation
+        -- k1 is too small, hence we add one and need one fixup step less.
+        -- If log x < 0, the approximation errs rather on the high side.
+        -- That is usually more than compensated for by ignoring the
+        -- fractional part of logBase 2 x, but when x is a power of 1/2
+        -- or slightly larger and the exponent is a multiple of the
+        -- denominator of the rational approximation to logBase 10 2,
+        -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,
+        -- we get a leading zero-digit we don't want.
+        -- With the approximation 3/10, this happened for
+        -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.
+        -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x
+        -- for IEEE-ish floating point types with exponent fields
+        -- <= 17 bits and mantissae of several thousand bits, earlier
+        -- convergents to logBase 10 2 would fail for long double.
+        -- Using quot instead of div is a little faster and requires
+        -- fewer fixup steps for negative lx.
+        let lx = p - 1 + e0
+            k1 = (lx * 8651) `quot` 28738
+        in if lx >= 0 then k1 + 1 else k1
+     else
+        -- f :: Integer, log :: Float -> Float,
+        --               ceiling :: Float -> Int
+        ceiling ((log (fromInteger (f+1) :: Float) +
+                 fromIntegral 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) `quotRem` 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 fromIntegral (reverse rds), k)
+
+------------------------------------------------------------------------
+-- Converting from a Rational to a RealFloa
+------------------------------------------------------------------------
+
+{-
+[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):
+-}
+
+-- | Converts a 'Rational' value into any type in class 'RealFloat'.
+{-# RULES
+"fromRat/Float"     fromRat = (fromRational :: Rational -> Float)
+"fromRat/Double"    fromRat = (fromRational :: Rational -> Double)
+  #-}
+
+{-# NOINLINE [1] fromRat #-}
+fromRat :: (RealFloat a) => Rational -> a
+
+-- Deal with special cases first, delegating the real work to fromRat'
+fromRat (n :% 0) | n > 0     =  1/0        -- +Infinity
+                 | n < 0     = -1/0        -- -Infinity
+                 | otherwise =  0/0        -- NaN
+
+fromRat (n :% d) | n > 0     = fromRat' (n :% d)
+                 | n < 0     = - fromRat' ((-n) :% d)
+                 | otherwise = encodeFloat 0 0             -- Zero
+
+-- 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
+-- Invariant: argument is strictly positive
+fromRat' x = r
+  where b = floatRadix r
+        p = floatDigits r
+        (minExp0, _) = floatRange r
+        minExp = minExp0 - p            -- the real minimum exponent
+        xMax   = toRational (expt b p)
+        p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+        -- if x = n/d and ln = integerLogBase b n, ld = integerLogBase b d,
+        -- then b^(ln-ld-1) < x < b^(ln-ld+1)
+        f = if p0 < 0 then 1 :% expt b (-p0) else expt b p0 :% 1
+        x0 = x / f
+        -- if ln - ld >= minExp0, then b^(p-1) < x0 < b^(p+1), so there's at most
+        -- one scaling step needed, otherwise, x0 < b^p and no scaling is needed
+        (x', p') = if x0 >= xMax then (x0 / toRational b, p0+1) else (x0, p0)
+        r = encodeFloat (round 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
+        if base == 10 && n <= maxExpt10 then
+            expts10!n
+        else
+            base^n
+
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+maxExpt10 :: Int
+maxExpt10 = 324
+
+expts10 :: Array Int Integer
+expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]
+
+-- 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, except for base 2, where
+-- we take advantage of the representation of Integers.
+-- The general case could be improved by a lookup table for
+-- approximating the result by integerLog2 i / integerLog2 b.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i
+   | i < b     = 0
+   | b == 2    = I# (integerLog2# i)
+   | otherwise = I# (integerLogBase# b i)
+
+{-
+Unfortunately, the old conversion code was awfully slow due to
+a) a slow integer logarithm
+b) repeated calculation of gcd's
+
+For the case of Rational's coming from a Float or Double via toRational,
+we can exploit the fact that the denominator is a power of two, which for
+these brings a huge speedup since we need only shift and add instead
+of division.
+
+The below is an adaption of fromRat' for the conversion to
+Float or Double exploiting the known floatRadix and avoiding
+divisions as much as possible.
+-}
+
+{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float,
+                            Int -> Int -> Integer -> Integer -> Double #-}
+fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a
+-- Invariant: n and d strictly positive
+fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =
+    case integerLog2IsPowerOf2# d of
+      (# ld#, pw# #)
+        | isTrue# (pw# ==# 0#) ->
+          case integerLog2# n of
+            ln# | isTrue# (ln# >=# (ld# +# me# -# 1#)) ->
+                  -- this means n/d >= 2^(minEx-1), i.e. we are guaranteed to get
+                  -- a normalised number, round to mantDigs bits
+                  if isTrue# (ln# <# md#)
+                    then encodeFloat n (I# (negateInt# ld#))
+                    else let n'  = n `shiftR` (I# (ln# +# 1# -# md#))
+                             n'' = case roundingMode# n (ln# -# md#) of
+                                    0# -> n'
+                                    2# -> n' + 1
+                                    _  -> case fromInteger n' .&. (1 :: Int) of
+                                            0 -> n'
+                                            _ -> n' + 1
+                         in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#))
+                | otherwise ->
+                  -- n/d < 2^(minEx-1), a denorm or rounded to 2^(minEx-1)
+                  -- the exponent for encoding is always minEx-mantDigs
+                  -- so we must shift right by (minEx-mantDigs) - (-ld)
+                  case ld# +# (me# -# md#) of
+                    ld'# | isTrue# (ld'# <=# 0#) -> -- we would shift left, so we don't shift
+                           encodeFloat n (I# ((me# -# md#) -# ld'#))
+                         | isTrue# (ld'# <=# ln#) ->
+                           let n' = n `shiftR` (I# ld'#)
+                           in case roundingMode# n (ld'# -# 1#) of
+                                0# -> encodeFloat n' (minEx - mantDigs)
+                                1# -> if fromInteger n' .&. (1 :: Int) == 0
+                                        then encodeFloat n' (minEx-mantDigs)
+                                        else encodeFloat (n' + 1) (minEx-mantDigs)
+                                _  -> encodeFloat (n' + 1) (minEx-mantDigs)
+                         | isTrue# (ld'# ># (ln# +# 1#)) -> encodeFloat 0 0 -- result of shift < 0.5
+                         | otherwise ->  -- first bit of n shifted to 0.5 place
+                           case integerLog2IsPowerOf2# n of
+                            (# _, 0# #) -> encodeFloat 0 0  -- round to even
+                            (# _, _ #)  -> encodeFloat 1 (minEx - mantDigs)
+        | otherwise ->
+          let ln = I# (integerLog2# n)
+              ld = I# ld#
+              -- 2^(ln-ld-1) < n/d < 2^(ln-ld+1)
+              p0 = max minEx (ln - ld)
+              (n', d')
+                | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d)
+                | p0 == mantDigs = (n, d)
+                | otherwise     = (n, d `shiftL` (p0 - mantDigs))
+              -- if ln-ld < minEx, then n'/d' < 2^mantDigs, else
+              -- 2^(mantDigs-1) < n'/d' < 2^(mantDigs+1) and we
+              -- may need one scaling step
+              scale p a b
+                | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1)
+                | otherwise = (p, a, b)
+              (p', n'', d'') = scale (p0-mantDigs) n' d'
+              -- n''/d'' < 2^mantDigs and p' == minEx-mantDigs or n''/d'' >= 2^(mantDigs-1)
+              rdq = case n'' `quotRem` d'' of
+                     (q,r) -> case compare (r `shiftL` 1) d'' of
+                                LT -> q
+                                EQ -> if fromInteger q .&. (1 :: Int) == 0
+                                        then q else q+1
+                                GT -> q+1
+          in  encodeFloat rdq p'
+
+------------------------------------------------------------------------
+-- Floating point numeric primops
+------------------------------------------------------------------------
+
+-- Definitions of the boxed PrimOps; these will be
+-- used in the case of partial applications, etc.
+
+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) = isTrue# (gtFloat# x y)
+geFloat     (F# x) (F# y) = isTrue# (geFloat# x y)
+eqFloat     (F# x) (F# y) = isTrue# (eqFloat# x y)
+neFloat     (F# x) (F# y) = isTrue# (neFloat# x y)
+ltFloat     (F# x) (F# y) = isTrue# (ltFloat# x y)
+leFloat     (F# x) (F# y) = isTrue# (leFloat# x y)
+
+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) = isTrue# (x >##  y)
+geDouble    (D# x) (D# y) = isTrue# (x >=## y)
+eqDouble    (D# x) (D# y) = isTrue# (x ==## y)
+neDouble    (D# x) (D# y) = isTrue# (x /=## y)
+ltDouble    (D# x) (D# y) = isTrue# (x <##  y)
+leDouble    (D# x) (D# y) = isTrue# (x <=## y)
+
+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)
+
+foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
+foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
+foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
+foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
+foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int
+
+foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
+foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
+foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
+foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
+foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
+
+------------------------------------------------------------------------
+-- Coercion rules
+------------------------------------------------------------------------
+
+word2Double :: Word -> Double
+word2Double (W# w) = D# (word2Double# w)
+
+word2Float :: Word -> Float
+word2Float (W# w) = F# (word2Float# w)
+
+{-# RULES
+"fromIntegral/Int->Float"   fromIntegral = int2Float
+"fromIntegral/Int->Double"  fromIntegral = int2Double
+"fromIntegral/Word->Float"  fromIntegral = word2Float
+"fromIntegral/Word->Double" fromIntegral = word2Double
+"realToFrac/Float->Float"   realToFrac   = id :: Float -> Float
+"realToFrac/Float->Double"  realToFrac   = float2Double
+"realToFrac/Double->Float"  realToFrac   = double2Float
+"realToFrac/Double->Double" realToFrac   = id :: Double -> Double
+"realToFrac/Int->Double"    realToFrac   = int2Double   -- See Note [realToFrac int-to-float]
+"realToFrac/Int->Float"     realToFrac   = int2Float    --      ..ditto
+    #-}
+
+{-
+Note [realToFrac int-to-float]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don found that the RULES for realToFrac/Int->Double and simliarly
+Float made a huge difference to some stream-fusion programs.  Here's
+an example
+
+      import Data.Array.Vector
+
+      n = 40000000
+
+      main = do
+            let c = replicateU n (2::Double)
+                a = mapU realToFrac (enumFromToU 0 (n-1) ) :: UArr Double
+            print (sumU (zipWithU (*) c a))
+
+Without the RULE we get this loop body:
+
+      case $wtoRational sc_sY4 of ww_aM7 { (# ww1_aM9, ww2_aMa #) ->
+      case $wfromRat ww1_aM9 ww2_aMa of tpl_X1P { D# ipv_sW3 ->
+      Main.$s$wfold
+        (+# sc_sY4 1)
+        (+# wild_X1i 1)
+        (+## sc2_sY6 (*## 2.0 ipv_sW3))
+
+And with the rule:
+
+     Main.$s$wfold
+        (+# sc_sXT 1)
+        (+# wild_X1h 1)
+        (+## sc2_sXV (*## 2.0 (int2Double# sc_sXT)))
+
+The running time of the program goes from 120 seconds to 0.198 seconds
+with the native backend, and 0.143 seconds with the C backend.
+
+A few more details in Trac #2251, and the patch message
+"Add RULES for realToFrac from Int".
+-}
+
+-- Utils
+
+showSignedFloat :: (RealFloat a)
+  => (a -> ShowS)       -- ^ a function that can show unsigned values
+  -> Int                -- ^ the precedence of the enclosing context
+  -> a                  -- ^ the value to show
+  -> ShowS
+showSignedFloat showPos p x
+   | x < 0 || isNegativeZero x
+       = showParen (p > 6) (showChar '-' . showPos (-x))
+   | otherwise = showPos x
+
+{-
+We need to prevent over/underflow of the exponent in encodeFloat when
+called from scaleFloat, hence we clamp the scaling parameter.
+We must have a large enough range to cover the maximum difference of
+exponents returned by decodeFloat.
+-}
+clamp :: Int -> Int -> Int
+clamp bd k = max (-bd) (min bd k)