{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , GHCForeignImportPrim
           , NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
           , UnliftedFFITypes
  #-}
{-# LANGUAGE CApiFFI #-}
-- We believe we could deorphan this module, by moving lots of things
-- around, but we haven't got there yet:
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- 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', the classes 'Floating' and 'RealFloat' and
-- casting between Word32 and Float and Word64 and Double.
--
-----------------------------------------------------------------------------

#include "ieee-flpt.h"
#include "MachDeps.h"

module GHC.Float
   ( module GHC.Float
   , Float(..), Double(..), Float#, Double#
   , double2Int, int2Double, float2Int, int2Float

    -- * Monomorphic equality operators
    -- | See GHC.Classes#matching_overloaded_methods_in_rules
   , eqFloat, eqDouble
   ) 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.Word
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.
--
-- The Haskell Report defines no laws for 'Floating'. However, @('+')@, @('*')@
-- and 'exp' are customarily expected to define an exponential field and have
-- the following properties:
--
-- * @exp (a + b)@ = @exp a * exp b@
-- * @exp (fromInteger 0)@ = @fromInteger 1@
--
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

    -- | @'log1p' x@ computes @'log' (1 + x)@, but provides more precise
    -- results for small (absolute) values of @x@ if possible.
    --
    -- @since 4.9.0.0
    log1p               :: a -> a

    -- | @'expm1' x@ computes @'exp' x - 1@, but provides more precise
    -- results for small (absolute) values of @x@ if possible.
    --
    -- @since 4.9.0.0
    expm1               :: a -> a

    -- | @'log1pexp' x@ computes @'log' (1 + 'exp' x)@, but provides more
    -- precise results if possible.
    --
    -- Examples:
    --
    -- * if @x@ is a large negative number, @'log' (1 + 'exp' x)@ will be
    --   imprecise for the reasons given in 'log1p'.
    --
    -- * if @'exp' x@ is close to @-1@, @'log' (1 + 'exp' x)@ will be
    --   imprecise for the reasons given in 'expm1'.
    --
    -- @since 4.9.0.0
    log1pexp            :: a -> a

    -- | @'log1mexp' x@ computes @'log' (1 - 'exp' x)@, but provides more
    -- precise results if possible.
    --
    -- Examples:
    --
    -- * if @x@ is a large negative number, @'log' (1 - 'exp' x)@ will be
    --   imprecise for the reasons given in 'log1p'.
    --
    -- * if @'exp' x@ is close to @1@, @'log' (1 - 'exp' x)@ will be
    --   imprecise for the reasons given in 'expm1'.
    --
    -- @since 4.9.0.0
    log1mexp            :: 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

    {-# INLINE log1p #-}
    {-# INLINE expm1 #-}
    {-# INLINE log1pexp #-}
    {-# INLINE log1mexp #-}
    log1p x = log (1 + x)
    expm1 x = exp x - 1
    log1pexp x = log1p (exp x)
    log1mexp x = log1p (negate (exp 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@,
    -- @'Prelude.uncurry' 'encodeFloat' ('decodeFloat' x) = x@.
    -- @'encodeFloat' m n@ is one of the two closest representable
    -- floating-point numbers to @m*b^^n@ (or @±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
------------------------------------------------------------------------

-- | @since 2.01
-- Note that due to the presence of @NaN@, not all elements of 'Float' have an
-- additive inverse.
--
-- >>> 0/0 + (negate 0/0 :: Float)
-- NaN
--
-- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't
-- have an additive identity
--
-- >>> 0 + (-0 :: Float)
-- 0.0
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       =  fabsFloat 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)

-- | @since 2.01
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#)

-- | @since 2.01
-- Note that due to the presence of @NaN@, not all elements of 'Float' have an
-- multiplicative inverse.
--
-- >>> 0/0 * (recip 0/0 :: Float)
-- NaN
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
  #-}
-- | @since 2.01
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

-- | @since 2.01
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             =  asinhFloat x
    acosh x             =  acoshFloat x
    atanh x             =  atanhFloat x

    log1p = log1pFloat
    expm1 = expm1Float

    log1mexp a
      | a <= log 2 = log (negate (expm1Float a))
      | otherwise  = log1pFloat (negate (exp a))
    {-# INLINE log1mexp #-}
    log1pexp a
      | a <= 18   = log1pFloat (exp a)
      | a <= 100  = a + exp (negate a)
      | otherwise = a
    {-# INLINE log1pexp #-}

-- | @since 2.01
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

-- | @since 2.01
instance  Show Float  where
    showsPrec   x = showSignedFloat showFloat x
    showList = showList__ (showsPrec 0)

------------------------------------------------------------------------
-- Double
------------------------------------------------------------------------

-- | @since 2.01
-- Note that due to the presence of @NaN@, not all elements of 'Double' have an
-- additive inverse.
--
-- >>> 0/0 + (negate 0/0 :: Double)
-- NaN
--
-- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't
-- have an additive identity
--
-- >>> 0 + (-0 :: Double)
-- 0.0
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       =  fabsDouble 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)

-- | @since 2.01
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#)

-- | @since 2.01
-- Note that due to the presence of @NaN@, not all elements of 'Double' have an
-- multiplicative inverse.
--
-- >>> 0/0 * (recip 0/0 :: Double)
-- NaN
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

-- | @since 2.01
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             =  asinhDouble x
    acosh x             =  acoshDouble x
    atanh x             =  atanhDouble x

    log1p = log1pDouble
    expm1 = expm1Double

    log1mexp a
      | a <= log 2 = log (negate (expm1Double a))
      | otherwise  = log1pDouble (negate (exp a))
    {-# INLINE log1mexp #-}
    log1pexp a
      | a <= 18   = log1pDouble (exp a)
      | a <= 100  = a + exp (negate a)
      | otherwise = a
    {-# INLINE log1pexp #-}

-- 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
  #-}
-- | @since 2.01
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

-- | @since 2.01
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

-- | @since 2.01
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.)
-}

-- | @since 2.01
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

-- | @since 2.01
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'
          []      -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []"
       Just d | d <= 0 ->
        -- handle this case specifically since we need to omit the
        -- decimal point as well (#15115).
        -- Note that this handles negative precisions as well for consistency
        -- (see #15509).
        case is of
          [0] -> "0e0"
          _ ->
           let
             (ei,is') = roundTo base 1 is
             n:_ = map intToDigit (if ei > 0 then init is' else is')
           in n : 'e' : show (e-1+ei)
       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)
    _       -> errorWithoutStackTrace "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, ltFloat, leFloat :: Float -> Float -> Bool
gtFloat     (F# x) (F# y) = isTrue# (gtFloat# x y)
geFloat     (F# x) (F# y) = isTrue# (geFloat# x y)
ltFloat     (F# x) (F# y) = isTrue# (ltFloat# x y)
leFloat     (F# x) (F# y) = isTrue# (leFloat# x y)

expFloat, logFloat, sqrtFloat, fabsFloat :: Float -> Float
sinFloat, cosFloat, tanFloat  :: Float -> Float
asinFloat, acosFloat, atanFloat  :: Float -> Float
sinhFloat, coshFloat, tanhFloat  :: Float -> Float
asinhFloat, acoshFloat, atanhFloat  :: Float -> Float
expFloat    (F# x) = F# (expFloat# x)
logFloat    (F# x) = F# (logFloat# x)
sqrtFloat   (F# x) = F# (sqrtFloat# x)
fabsFloat   (F# x) = F# (fabsFloat# 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)
asinhFloat  (F# x) = F# (asinhFloat# x)
acoshFloat  (F# x) = F# (acoshFloat# x)
atanhFloat  (F# x) = F# (atanhFloat# 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, leDouble, ltDouble :: Double -> Double -> Bool
gtDouble    (D# x) (D# y) = isTrue# (x >##  y)
geDouble    (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, fabsDouble :: Double -> Double
sinDouble, cosDouble, tanDouble  :: Double -> Double
asinDouble, acosDouble, atanDouble  :: Double -> Double
sinhDouble, coshDouble, tanhDouble  :: Double -> Double
asinhDouble, acoshDouble, atanhDouble  :: Double -> Double
expDouble    (D# x) = D# (expDouble# x)
logDouble    (D# x) = D# (logDouble# x)
sqrtDouble   (D# x) = D# (sqrtDouble# x)
fabsDouble   (D# x) = D# (fabsDouble# 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)
asinhDouble  (D# x) = D# (asinhDouble# x)
acoshDouble  (D# x) = D# (acoshDouble# x)
atanhDouble  (D# x) = D# (atanhDouble# 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

------------------------------------------------------------------------
-- libm imports for extended floating
------------------------------------------------------------------------
foreign import capi unsafe "math.h log1p" log1pDouble :: Double -> Double
foreign import capi unsafe "math.h expm1" expm1Double :: Double -> Double
foreign import capi unsafe "math.h log1pf" log1pFloat :: Float -> Float
foreign import capi unsafe "math.h expm1f" expm1Float :: Float -> Float

------------------------------------------------------------------------
-- 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)

{-
Note [Casting from integral to floating point types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To implement something like `reinterpret_cast` from C++ to go from a
floating-point type to an integral type one might niavely think that the
following should work:

      cast :: Float -> Word32
      cast (F# f#) = W32# (unsafeCoerce# f#)

Unfortunately that is not the case, because all the `unsafeCoerce#` does is tell
the compiler that the types have changed. When one does the above cast and
tries to operate on the resulting `Word32` the code generator will generate code
that performs an integer/word operation on a floating-point register, which
results in a compile error.

The correct way of implementing `reinterpret_cast` to implement a primpop, but
that requires a unique implementation for all supported archetectures. The next
best solution is to write the value from the source register to memory and then
read it from memory into the destination register and the best way to do that
is using CMM.
-}

-- | @'castWord32ToFloat' w@ does a bit-for-bit copy from an integral value
-- to a floating-point value.
--
-- @since 4.10.0.0

{-# INLINE castWord32ToFloat #-}
castWord32ToFloat :: Word32 -> Float
castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#)

foreign import prim "stg_word32ToFloatzh"
    stgWord32ToFloat :: Word# -> Float#

-- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value
-- to an integral value.
--
-- @since 4.10.0.0

{-# INLINE castFloatToWord32 #-}
castFloatToWord32 :: Float -> Word32
castFloatToWord32 (F# f#) = W32# (stgFloatToWord32 f#)

foreign import prim "stg_floatToWord32zh"
    stgFloatToWord32 :: Float# -> Word#

-- | @'castWord64ToDouble' w@ does a bit-for-bit copy from an integral value
-- to a floating-point value.
--
-- @since 4.10.0.0

{-# INLINE castWord64ToDouble #-}
castWord64ToDouble :: Word64 -> Double
castWord64ToDouble (W64# w) = D# (stgWord64ToDouble w)

foreign import prim "stg_word64ToDoublezh"
#if WORD_SIZE_IN_BITS == 64
    stgWord64ToDouble :: Word# -> Double#
#else
    stgWord64ToDouble :: Word64# -> Double#
#endif

-- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value
-- to an integral value.
--
-- @since 4.10.0.0

{-# INLINE castDoubleToWord64 #-}
castDoubleToWord64 :: Double -> Word64
castDoubleToWord64 (D# d#) = W64# (stgDoubleToWord64 d#)

foreign import prim "stg_doubleToWord64zh"
#if WORD_SIZE_IN_BITS == 64
    stgDoubleToWord64 :: Double# -> Word#
#else
    stgDoubleToWord64 :: Double# -> Word64#
#endif


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Foreign
-- Copyright   :  (c) The University of Glasgow, 2008-2011
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Foreign marshalling support for CStrings with configurable encodings
--
-----------------------------------------------------------------------------

module GHC.Foreign (
    -- * C strings with a configurable encoding

    -- conversion of C strings into Haskell strings
    --
    peekCString,
    peekCStringLen,

    -- conversion of Haskell strings into C strings
    --
    newCString,
    newCStringLen,

    -- conversion of Haskell strings into C strings using temporary storage
    --
    withCString,
    withCStringLen,
    withCStringsLen,

    charIsRepresentable,
  ) where

import Foreign.Marshal.Array
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable

import Data.Word

-- Imports for the locale-encoding version of marshallers

import Data.Tuple (fst)

import GHC.Show ( show )

import Foreign.Marshal.Alloc
import Foreign.ForeignPtr

import GHC.Debug
import GHC.List
import GHC.Num
import GHC.Base

import GHC.IO
import GHC.IO.Exception
import GHC.IO.Buffer
import GHC.IO.Encoding.Types

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False

putDebugMsg :: String -> IO ()
putDebugMsg | c_DEBUG_DUMP = debugLn
            | otherwise    = const (return ())

-- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:
type CString    = Ptr CChar
type CStringLen = (Ptr CChar, Int)

-- exported functions
-- ------------------

-- | Marshal a NUL terminated C string into a Haskell string.
--
peekCString    :: TextEncoding -> CString -> IO String
peekCString enc cp = do
    sz <- lengthArray0 nUL cp
    peekEncodedCString enc (cp, sz * cCharSize)

-- | Marshal a C string with explicit length into a Haskell string.
--
peekCStringLen           :: TextEncoding -> CStringLen -> IO String
peekCStringLen = peekEncodedCString

-- | Marshal a Haskell string into a NUL terminated C string.
--
-- * the Haskell string may /not/ contain any NUL characters
--
-- * new storage is allocated for the C string and must be
--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
--   'Foreign.Marshal.Alloc.finalizerFree'.
--
newCString :: TextEncoding -> String -> IO CString
newCString enc = liftM fst . newEncodedCString enc True

-- | Marshal a Haskell string into a C string (ie, character array) with
-- explicit length information.
--
-- * new storage is allocated for the C string and must be
--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
--   'Foreign.Marshal.Alloc.finalizerFree'.
--
newCStringLen     :: TextEncoding -> String -> IO CStringLen
newCStringLen enc = newEncodedCString enc False

-- | Marshal a Haskell string into a NUL terminated C string using temporary
-- storage.
--
-- * the Haskell string may /not/ contain any NUL characters
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a
withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp

-- | Marshal a Haskell string into a C string (ie, character array)
-- in temporary storage, with explicit length information.
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCStringLen         :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
withCStringLen enc = withEncodedCString enc False

-- | Marshal a list of Haskell strings into an array of NUL terminated C strings
-- using temporary storage.
--
-- * the Haskell strings may /not/ contain any NUL characters
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCStringsLen :: TextEncoding
                -> [String]
                -> (Int -> Ptr CString -> IO a)
                -> IO a
withCStringsLen enc strs f = go [] strs
  where
  go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss
  go cs [] = withArrayLen (reverse cs) f

-- | Determines whether a character can be accurately encoded in a
-- 'Foreign.C.String.CString'.
--
-- Pretty much anyone who uses this function is in a state of sin because
-- whether or not a character is encodable will, in general, depend on the
-- context in which it occurs.
charIsRepresentable :: TextEncoding -> Char -> IO Bool
-- We force enc explicitly because `catch` is lazy in its
-- first argument. We would probably like to force c as well,
-- but unfortunately worker/wrapper produces very bad code for
-- that.
--
-- TODO If this function is performance-critical, it would probably
-- pay to use a single-character specialization of withCString. That
-- would allow worker/wrapper to actually eliminate Char boxes, and
-- would also get rid of the completely unnecessary cons allocation.
charIsRepresentable !enc c =
  withCString enc [c]
              (\cstr -> do str <- peekCString enc cstr
                           case str of
                             [ch] | ch == c -> pure True
                             _ -> pure False)
    `catch`
       \(_ :: IOException) -> pure False

-- auxiliary definitions
-- ----------------------

-- C's end of string character
nUL :: CChar
nUL  = 0

-- Size of a CChar in bytes
cCharSize :: Int
cCharSize = sizeOf (undefined :: CChar)

{-# INLINE peekEncodedCString #-}
peekEncodedCString :: TextEncoding -- ^ Encoding of CString
                   -> CStringLen
                   -> IO String    -- ^ String in Haskell terms
peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)
  = bracket mk_decoder close $ \decoder -> do
      let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII
      from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p)
      to <- newCharBuffer chunk_size WriteBuffer

      let go !iteration from = do
            (why, from', to') <- encode decoder from to
            if isEmptyBuffer from'
             then
              -- No input remaining: @why@ will be InputUnderflow, but we don't care
              withBuffer to' $ peekArray (bufferElems to')
             else do
              -- Input remaining: what went wrong?
              putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why)
              (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because
                                            InputUnderflow  -> recover decoder from' to' -- they indicate malformed/truncated input
                                            OutputUnderflow -> return (from', to')       -- We will have more space next time round
              putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'')
              putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'')
              to_chars <- withBuffer to'' $ peekArray (bufferElems to'')
              fmap (to_chars++) $ go (iteration + 1) from''

      go (0 :: Int) from0

{-# INLINE withEncodedCString #-}
withEncodedCString :: TextEncoding         -- ^ Encoding of CString to create
                   -> Bool                 -- ^ Null-terminate?
                   -> String               -- ^ String to encode
                   -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory
                   -> IO a
withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act
  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
      from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p

      let go !iteration to_sz_bytes = do
           putDebugMsg ("withEncodedCString: " ++ show iteration)
           allocaBytes to_sz_bytes $ \to_p -> do
            mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes act
            case mb_res of
              Nothing  -> go (iteration + 1) (to_sz_bytes * 2)
              Just res -> return res

      -- If the input string is ASCII, this value will ensure we only allocate once
      go (0 :: Int) (cCharSize * (sz + 1))

{-# INLINE newEncodedCString #-}
newEncodedCString :: TextEncoding  -- ^ Encoding of CString to create
                  -> Bool          -- ^ Null-terminate?
                  -> String        -- ^ String to encode
                  -> IO CStringLen
newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s
  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
      from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p

      let go !iteration to_p to_sz_bytes = do
           putDebugMsg ("newEncodedCString: " ++ show iteration)
           mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes return
           case mb_res of
             Nothing  -> do
                 let to_sz_bytes' = to_sz_bytes * 2
                 to_p' <- reallocBytes to_p to_sz_bytes'
                 go (iteration + 1) to_p' to_sz_bytes'
             Just res -> return res

      -- If the input string is ASCII, this value will ensure we only allocate once
      let to_sz_bytes = cCharSize * (sz + 1)
      to_p <- mallocBytes to_sz_bytes
      go (0 :: Int) to_p to_sz_bytes

tryFillBufferAndCall :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
                     -> (CStringLen -> IO a) -> IO (Maybe a)
tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do
    to_fp <- newForeignPtr_ to_p
    go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer)
  where
    go !iteration (from, to) = do
      (why, from', to') <- encode encoder from to
      putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from')
      if isEmptyBuffer from'
       then if null_terminate && bufferAvailable to' == 0
             then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer
             else do
               -- Awesome, we had enough buffer
               let bytes = bufferElems to'
               withBuffer to' $ \to_ptr -> do
                   when null_terminate $ pokeElemOff to_ptr (bufR to') 0
                   fmap Just $ act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes*
       else case why of -- We didn't consume all of the input
              InputUnderflow  -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad
              InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid
              OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude
           , BangPatterns
           , MagicHash
           , UnboxedTuples
  #-}
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.ForeignPtr
-- Copyright   :  (c) The University of Glasgow, 1992-2003
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- GHC's implementation of the 'ForeignPtr' data type.
--
-----------------------------------------------------------------------------

module GHC.ForeignPtr
  (
        ForeignPtr(..),
        ForeignPtrContents(..),
        FinalizerPtr,
        FinalizerEnvPtr,
        newForeignPtr_,
        mallocForeignPtr,
        mallocPlainForeignPtr,
        mallocForeignPtrBytes,
        mallocPlainForeignPtrBytes,
        mallocForeignPtrAlignedBytes,
        mallocPlainForeignPtrAlignedBytes,
        addForeignPtrFinalizer,
        addForeignPtrFinalizerEnv,
        touchForeignPtr,
        unsafeForeignPtrToPtr,
        castForeignPtr,
        plusForeignPtr,
        newConcForeignPtr,
        addForeignPtrConcFinalizer,
        finalizeForeignPtr
  ) where

import Foreign.Storable
import Data.Foldable    ( sequence_ )

import GHC.Show
import GHC.Base
import GHC.IORef
import GHC.STRef        ( STRef(..) )
import GHC.Ptr          ( Ptr(..), FunPtr(..) )

-- |The type 'ForeignPtr' represents references to objects that are
-- maintained in a foreign language, i.e., that are not part of the
-- data structures usually managed by the Haskell storage manager.
-- The essential difference between 'ForeignPtr's and vanilla memory
-- references of type @Ptr a@ is that the former may be associated
-- with /finalizers/. A finalizer is a routine that is invoked when
-- the Haskell storage manager detects that - within the Haskell heap
-- and stack - there are no more references left that are pointing to
-- the 'ForeignPtr'.  Typically, the finalizer will, then, invoke
-- routines in the foreign language that free the resources bound by
-- the foreign object.
--
-- The 'ForeignPtr' is parameterised in the same way as 'Ptr'.  The
-- type argument of 'ForeignPtr' should normally be an instance of
-- class 'Storable'.
--
data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
        -- The Addr# in the ForeignPtr object is intentionally stored
        -- separately from the finalizer. The primary aim of the
        -- representation is to make withForeignPtr efficient; in fact,
        -- withForeignPtr should be just as efficient as unpacking a
        -- Ptr, and multiple withForeignPtrs can share an unpacked
        -- ForeignPtr. As a secondary benefit, this representation
        -- allows pointers to subregions within the same overall block
        -- to share the same finalizer (see 'plusForeignPtr'). Note
        -- that touchForeignPtr only has to touch the ForeignPtrContents
        -- object, because that ensures that whatever the finalizer is
        -- attached to is kept alive.

data Finalizers
  = NoFinalizers
  | CFinalizers (Weak# ())
  | HaskellFinalizers [IO ()]

data ForeignPtrContents
  = PlainForeignPtr !(IORef Finalizers)
  | MallocPtr      (MutableByteArray# RealWorld) !(IORef Finalizers)
  | PlainPtr       (MutableByteArray# RealWorld)

-- | @since 2.01
instance Eq (ForeignPtr a) where
    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q

-- | @since 2.01
instance Ord (ForeignPtr a) where
    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)

-- | @since 2.01
instance Show (ForeignPtr a) where
    showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)

-- |A finalizer is represented as a pointer to a foreign function that, at
-- finalisation time, gets as an argument a plain pointer variant of the
-- foreign pointer that the finalizer is associated with.
--
-- Note that the foreign function /must/ use the @ccall@ calling convention.
--
type FinalizerPtr a        = FunPtr (Ptr a -> IO ())
type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())

newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
--
-- ^Turns a plain memory reference into a foreign object by
-- associating a finalizer - given by the monadic operation - with the
-- reference.  The storage manager will start the finalizer, in a
-- separate thread, some time after the last reference to the
-- @ForeignPtr@ is dropped.  There is no guarantee of promptness, and
-- in fact there is no guarantee that the finalizer will eventually
-- run at all.
--
-- Note that references from a finalizer do not necessarily prevent
-- another object from being finalized.  If A's finalizer refers to B
-- (perhaps using 'touchForeignPtr', then the only guarantee is that
-- B's finalizer will never be started before A's.  If both A and B
-- are unreachable, then both finalizers will start together.  See
-- 'touchForeignPtr' for more on finalizer ordering.
--
newConcForeignPtr p finalizer
  = do fObj <- newForeignPtr_ p
       addForeignPtrConcFinalizer fObj finalizer
       return fObj

mallocForeignPtr :: Storable a => IO (ForeignPtr a)
-- ^ Allocate some memory and return a 'ForeignPtr' to it.  The memory
-- will be released automatically when the 'ForeignPtr' is discarded.
--
-- 'mallocForeignPtr' is equivalent to
--
-- >    do { p <- malloc; newForeignPtr finalizerFree p }
--
-- although it may be implemented differently internally: you may not
-- assume that the memory returned by 'mallocForeignPtr' has been
-- allocated with 'Foreign.Marshal.Alloc.malloc'.
--
-- GHC notes: 'mallocForeignPtr' has a heavily optimised
-- implementation in GHC.  It uses pinned memory in the garbage
-- collected heap, so the 'ForeignPtr' does not require a finalizer to
-- free the memory.  Use of 'mallocForeignPtr' and associated
-- functions is strongly recommended in preference to
-- 'Foreign.ForeignPtr.newForeignPtr' with a finalizer.
--
mallocForeignPtr = doMalloc undefined
  where doMalloc :: Storable b => b -> IO (ForeignPtr b)
        doMalloc a
          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"
          | otherwise = do
          r <- newIORef NoFinalizers
          IO $ \s ->
            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                               (MallocPtr mbarr# r) #)
            }
            where !(I# size)  = sizeOf a
                  !(I# align) = alignment a

-- | This function is similar to 'mallocForeignPtr', except that the
-- size of the memory required is given explicitly as a number of bytes.
mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
mallocForeignPtrBytes size | size < 0 =
  errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0"
mallocForeignPtrBytes (I# size) = do
  r <- newIORef NoFinalizers
  IO $ \s ->
     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->
       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                         (MallocPtr mbarr# r) #)
     }

-- | This function is similar to 'mallocForeignPtrBytes', except that the
-- size and alignment of the memory required is given explicitly as numbers of
-- bytes.
mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)
mallocForeignPtrAlignedBytes size _align | size < 0 =
  errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0"
mallocForeignPtrAlignedBytes (I# size) (I# align) = do
  r <- newIORef NoFinalizers
  IO $ \s ->
     case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                         (MallocPtr mbarr# r) #)
     }

-- | Allocate some memory and return a 'ForeignPtr' to it.  The memory
-- will be released automatically when the 'ForeignPtr' is discarded.
--
-- GHC notes: 'mallocPlainForeignPtr' has a heavily optimised
-- implementation in GHC.  It uses pinned memory in the garbage
-- collected heap, as for mallocForeignPtr. Unlike mallocForeignPtr, a
-- ForeignPtr created with mallocPlainForeignPtr carries no finalizers.
-- It is not possible to add a finalizer to a ForeignPtr created with
-- mallocPlainForeignPtr. This is useful for ForeignPtrs that will live
-- only inside Haskell (such as those created for packed strings).
-- Attempts to add a finalizer to a ForeignPtr created this way, or to
-- finalize such a pointer, will throw an exception.
--
mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)
mallocPlainForeignPtr = doMalloc undefined
  where doMalloc :: Storable b => b -> IO (ForeignPtr b)
        doMalloc a
          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"
          | otherwise = IO $ \s ->
            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                               (PlainPtr mbarr#) #)
            }
            where !(I# size)  = sizeOf a
                  !(I# align) = alignment a

-- | This function is similar to 'mallocForeignPtrBytes', except that
-- the internally an optimised ForeignPtr representation with no
-- finalizer is used. Attempts to add a finalizer will cause an
-- exception to be thrown.
mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes size | size < 0 =
  errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0"
mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
    case newPinnedByteArray# size s      of { (# s', mbarr# #) ->
       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                         (PlainPtr mbarr#) #)
     }

-- | This function is similar to 'mallocForeignPtrAlignedBytes', except that
-- the internally an optimised ForeignPtr representation with no
-- finalizer is used. Attempts to add a finalizer will cause an
-- exception to be thrown.
mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)
mallocPlainForeignPtrAlignedBytes size _align | size < 0 =
  errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0"
mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s ->
    case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                         (PlainPtr mbarr#) #)
     }

addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()
-- ^ This function adds a finalizer to the given foreign object.  The
-- finalizer will run /before/ all other finalizers for the same
-- object which have already been registered.
addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of
  PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p ()
  MallocPtr     _ r -> insertCFinalizer r fp 0# nullAddr# p c
  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"

-- Note [MallocPtr finalizers] (#10904)
--
-- When we have C finalizers for a MallocPtr, the memory is
-- heap-resident and would normally be recovered by the GC before the
-- finalizers run.  To prevent the memory from being reused too early,
-- we attach the MallocPtr constructor to the "value" field of the
-- weak pointer when we call mkWeak# in ensureCFinalizerWeak below.
-- The GC will keep this field alive until the finalizers have run.

addForeignPtrFinalizerEnv ::
  FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()
-- ^ Like 'addForeignPtrFinalizer' but the finalizer is passed an additional
-- environment parameter.
addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of
  PlainForeignPtr r -> insertCFinalizer r fp 1# ep p ()
  MallocPtr     _ r -> insertCFinalizer r fp 1# ep p c
  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"

addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
-- ^This function adds a finalizer to the given @ForeignPtr@.  The
-- finalizer will run /before/ all other finalizers for the same
-- object which have already been registered.
--
-- This is a variant of @addForeignPtrFinalizer@, where the finalizer
-- is an arbitrary @IO@ action.  When it is invoked, the finalizer
-- will run in a new thread.
--
-- NB. Be very careful with these finalizers.  One common trap is that
-- if a finalizer references another finalized value, it does not
-- prevent that value from being finalized.  In particular, 'System.IO.Handle's
-- are finalized objects, so a finalizer should not refer to a
-- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or
-- 'System.IO.stderr').
--
addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer =
  addForeignPtrConcFinalizer_ c finalizer

addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO ()
addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do
  noFinalizers <- insertHaskellFinalizer r finalizer
  if noFinalizers
     then IO $ \s ->
              case r of { IORef (STRef r#) ->
              case mkWeak# r# () (unIO $ foreignPtrFinalizer r) s of {
                (# s1, _ #) -> (# s1, () #) }}
     else return ()
addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do
  noFinalizers <- insertHaskellFinalizer r finalizer
  if noFinalizers
     then  IO $ \s ->
               case mkWeak# fo () finalizer' s of
                  (# s1, _ #) -> (# s1, () #)
     else return ()
  where
    finalizer' :: State# RealWorld -> (# State# RealWorld, () #)
    finalizer' = unIO (foreignPtrFinalizer r >> touch f)

addForeignPtrConcFinalizer_ _ _ =
  errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"

insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool
insertHaskellFinalizer r f = do
  !wasEmpty <- atomicModifyIORefP r $ \finalizers -> case finalizers of
      NoFinalizers -> (HaskellFinalizers [f], True)
      HaskellFinalizers fs -> (HaskellFinalizers (f:fs), False)
      _ -> noMixingError
  return wasEmpty

-- | A box around Weak#, private to this module.
data MyWeak = MyWeak (Weak# ())

insertCFinalizer ::
  IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> value -> IO ()
insertCFinalizer r fp flag ep p val = do
  MyWeak w <- ensureCFinalizerWeak r val
  IO $ \s -> case addCFinalizerToWeak# fp p flag ep w s of
      (# s1, 1# #) -> (# s1, () #)

      -- Failed to add the finalizer because some other thread
      -- has finalized w by calling foreignPtrFinalizer. We retry now.
      -- This won't be an infinite loop because that thread must have
      -- replaced the content of r before calling finalizeWeak#.
      (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p val) s1

ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak
ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do
  fin <- readIORef ref
  case fin of
      CFinalizers weak -> return (MyWeak weak)
      HaskellFinalizers{} -> noMixingError
      NoFinalizers -> IO $ \s ->
          case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) ->
             -- See Note [MallocPtr finalizers] (#10904)
          case atomicModifyMutVar2# r# (update w) s1 of
              { (# s2, _, (_, (weak, needKill )) #) ->
          if needKill
            then case finalizeWeak# w s2 of { (# s3, _, _ #) ->
              (# s3, weak #) }
            else (# s2, weak #) }}
  where
      update _ fin@(CFinalizers w) = (fin, (MyWeak w, True))
      update w NoFinalizers = (CFinalizers w, (MyWeak w, False))
      update _ _ = noMixingError

noMixingError :: a
noMixingError = errorWithoutStackTrace $
   "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++
   "in the same ForeignPtr"

foreignPtrFinalizer :: IORef Finalizers -> IO ()
foreignPtrFinalizer r = do
  fs <- atomicSwapIORef r NoFinalizers
             -- atomic, see #7170
  case fs of
    NoFinalizers -> return ()
    CFinalizers w -> IO $ \s -> case finalizeWeak# w s of
        (# s1, 1#, f #) -> f s1
        (# s1, _, _ #) -> (# s1, () #)
    HaskellFinalizers actions -> sequence_ actions

newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)
-- ^Turns a plain memory reference into a foreign pointer that may be
-- associated with finalizers by using 'addForeignPtrFinalizer'.
newForeignPtr_ (Ptr obj) =  do
  r <- newIORef NoFinalizers
  return (ForeignPtr obj (PlainForeignPtr r))

touchForeignPtr :: ForeignPtr a -> IO ()
-- ^This function ensures that the foreign object in
-- question is alive at the given place in the sequence of IO
-- actions. In particular 'Foreign.ForeignPtr.withForeignPtr'
-- does a 'touchForeignPtr' after it
-- executes the user action.
--
-- Note that this function should not be used to express dependencies
-- between finalizers on 'ForeignPtr's.  For example, if the finalizer
-- for a 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second
-- 'ForeignPtr' @F2@, then the only guarantee is that the finalizer
-- for @F2@ is never started before the finalizer for @F1@.  They
-- might be started together if for example both @F1@ and @F2@ are
-- otherwise unreachable, and in that case the scheduler might end up
-- running the finalizer for @F2@ first.
--
-- In general, it is not recommended to use finalizers on separate
-- objects with ordering constraints between them.  To express the
-- ordering robustly requires explicit synchronisation using @MVar@s
-- between the finalizers, but even then the runtime sometimes runs
-- multiple finalizers sequentially in a single thread (for
-- performance reasons), so synchronisation between finalizers could
-- result in artificial deadlock.  Another alternative is to use
-- explicit reference counting.
--
touchForeignPtr (ForeignPtr _ r) = touch r

touch :: ForeignPtrContents -> IO ()
touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)

unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
-- ^This function extracts the pointer component of a foreign
-- pointer.  This is a potentially dangerous operations, as if the
-- argument to 'unsafeForeignPtrToPtr' is the last usage
-- occurrence of the given foreign pointer, then its finalizer(s) will
-- be run, which potentially invalidates the plain pointer just
-- obtained.  Hence, 'touchForeignPtr' must be used
-- wherever it has to be guaranteed that the pointer lives on - i.e.,
-- has another usage occurrence.
--
-- To avoid subtle coding errors, hand written marshalling code
-- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather
-- than combinations of 'unsafeForeignPtrToPtr' and
-- 'touchForeignPtr'.  However, the latter routines
-- are occasionally preferred in tool generated marshalling code.
unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo

castForeignPtr :: ForeignPtr a -> ForeignPtr b
-- ^This function casts a 'ForeignPtr'
-- parameterised by one type into another type.
castForeignPtr = coerce

plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b
-- ^Advances the given address by the given offset in bytes.
--
-- The new 'ForeignPtr' shares the finalizer of the original,
-- equivalent from a finalization standpoint to just creating another
-- reference to the original. That is, the finalizer will not be
-- called before the new 'ForeignPtr' is unreachable, nor will it be
-- called an additional time due to this call, and the finalizer will
-- be called with the same address that it would have had this call
-- not happened, *not* the new address.
--
-- @since 4.10.0.0
plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c

-- | Causes the finalizers associated with a foreign pointer to be run
-- immediately.
finalizeForeignPtr :: ForeignPtr a -> IO ()
finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect
finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers
        where
                refFinalizers = case foreignPtr of
                        (PlainForeignPtr ref) -> ref
                        (MallocPtr     _ ref) -> ref
                        PlainPtr _            ->
                            errorWithoutStackTrace "finalizeForeignPtr PlainPtr"