{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}
module Numeric.Floating.IEEE.Internal.Half where
import           Data.Bits
import           Data.Coerce
import           Data.Word
import           Foreign.C.Types
import           GHC.Exts
import           GHC.Float.Compat (float2Double)
import           MyPrelude
import           Numeric.Floating.IEEE.Internal.Base
import           Numeric.Floating.IEEE.Internal.Classify
import           Numeric.Floating.IEEE.Internal.Conversion
import           Numeric.Floating.IEEE.Internal.FMA
import           Numeric.Floating.IEEE.Internal.NaN (RealFloatNaN)
import qualified Numeric.Floating.IEEE.Internal.NaN as NaN
import           Numeric.Floating.IEEE.Internal.NextFloat
import           Numeric.Floating.IEEE.Internal.Rounding
import           Numeric.Half hiding (isZero)
import qualified Numeric.Half

default ()

castHalfToWord16 :: Half -> Word16
castHalfToWord16 :: Half -> Word16
castHalfToWord16 (Half x :: CUShort
x) = CUShort -> Word16
forall a b. Coercible a b => a -> b
coerce CUShort
x
{-# INLINE castHalfToWord16 #-}

castWord16ToHalf :: Word16 -> Half
castWord16ToHalf :: Word16 -> Half
castWord16ToHalf x :: Word16
x = CUShort -> Half
Half (Word16 -> CUShort
forall a b. Coercible a b => a -> b
coerce Word16
x)
{-# INLINE castWord16ToHalf #-}

nextUpHalf :: Half -> Half
nextUpHalf :: Half -> Half
nextUpHalf x :: Half
x =
  case Half -> Word16
castHalfToWord16 Half
x of
    w :: Word16
w | Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x7c00
      , Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0xfc00 -> Half
x Half -> Half -> Half
forall a. Num a => a -> a -> a
+ Half
x -- NaN or negative infinity -> itself
    0x8000 -> Half
forall a. RealFloat a => a
minPositive -- -0 -> min positive
    w :: Word16
w | Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 15 -> Word16 -> Half
castWord16ToHalf (Word16
w Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- 1) -- negative
      | Bool
otherwise -> Word16 -> Half
castWord16ToHalf (Word16
w Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ 1) -- positive

nextDownHalf :: Half -> Half
nextDownHalf :: Half -> Half
nextDownHalf x :: Half
x =
  case Half -> Word16
castHalfToWord16 Half
x of
    w :: Word16
w | Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x7c00
      , Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7c00 -> Half
x Half -> Half -> Half
forall a. Num a => a -> a -> a
+ Half
x -- NaN or positive infinity -> itself
    0x0000 -> - Half
forall a. RealFloat a => a
minPositive -- +0 -> max negative
    w :: Word16
w | Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 15 -> Word16 -> Half
castWord16ToHalf (Word16
w Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ 1) -- negative
      | Bool
otherwise -> Word16 -> Half
castWord16ToHalf (Word16
w Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- 1) -- positive

nextTowardZeroHalf :: Half -> Half
nextTowardZeroHalf :: Half -> Half
nextTowardZeroHalf x :: Half
x =
  case Half -> Word16
castHalfToWord16 Half
x of
    w :: Word16
w | Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x7c00
      , Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7fff -> Half
x Half -> Half -> Half
forall a. Num a => a -> a -> a
+ Half
x -- NaN -> itself
    0x8000 -> Half
x -- -0 -> itself
    0x0000 -> Half
x -- +0 -> itself
    w :: Word16
w -> Word16 -> Half
castWord16ToHalf (Word16
w Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- 1) -- positive / negative

isNormalHalf :: Half -> Bool
isNormalHalf :: Half -> Bool
isNormalHalf x :: Half
x = let w :: Word16
w = Half -> Word16
castHalfToWord16 Half
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00
                 in Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7c00

isFiniteHalf :: Half -> Bool
isFiniteHalf :: Half -> Bool
isFiniteHalf x :: Half
x = let w :: Word16
w = Half -> Word16
castHalfToWord16 Half
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00
                 in Word16
w Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7c00

isSignMinusHalf :: Half -> Bool
isSignMinusHalf :: Half -> Bool
isSignMinusHalf x :: Half
x = let w :: Word16
w = Half -> Word16
castHalfToWord16 Half
x
                    in Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 15 Bool -> Bool -> Bool
&& (Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7c00 Bool -> Bool -> Bool
|| Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x3ff Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) -- all NaNs are treated as positive

classifyHalf :: Half -> Class
classifyHalf :: Half -> Class
classifyHalf x :: Half
x = let w :: Word16
w = Half -> Word16
castHalfToWord16 Half
x
                     s :: Bool
s = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 15
                     e :: Word16
e = (Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 10) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x1f -- exponent (5 bits)
                     m :: Word16
m = Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x3ff -- mantissa (10 bits without leading 1)
                 in case (Bool
s, Word16
e, Word16
m) of
                      (True,  0,    0) -> Class
NegativeZero
                      (False, 0,    0) -> Class
PositiveZero
                      (True,  0,    _) -> Class
NegativeSubnormal
                      (False, 0,    _) -> Class
PositiveSubnormal
                      (True,  0x1f, 0) -> Class
NegativeInfinity
                      (False, 0x1f, 0) -> Class
PositiveInfinity
                      (_,     0x1f, _) -> Class
QuietNaN -- treat all NaNs as quiet
                      (True,  _,    _) -> Class
NegativeNormal
                      (False, _,    _) -> Class
PositiveNormal

instance RealFloatNaN Half where
  copySign :: Half -> Half -> Half
copySign x :: Half
x y :: Half
y = Word16 -> Half
castWord16ToHalf ((Word16
x' Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7fff) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word16
y' Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x8000))
    where x' :: Word16
x' = Half -> Word16
castHalfToWord16 Half
x
          y' :: Word16
y' = Half -> Word16
castHalfToWord16 Half
y

  isSignMinus :: Half -> Bool
isSignMinus x :: Half
x = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Half -> Word16
castHalfToWord16 Half
x) 15

  isSignaling :: Half -> Bool
isSignaling x :: Half
x = Word16
x' Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7c00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x7c00 Bool -> Bool -> Bool
&& Word16
x' Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x7fff Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7c00 Bool -> Bool -> Bool
&& Bool -> Bool
not (Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
x' 9)
    where x' :: Word16
x' = Half -> Word16
castHalfToWord16 Half
x

  getPayload :: Half -> Half
getPayload x :: Half
x
    | Bool -> Bool
not (Half -> Bool
forall a. RealFloat a => a -> Bool
isNaN Half
x) = -1
    | Bool
otherwise = Word16 -> Half
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Half -> Word16
castHalfToWord16 Half
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x01ff)

  setPayload :: Half -> Half
setPayload x :: Half
x
    | 0 Half -> Half -> Bool
forall a. Ord a => a -> a -> Bool
<= Half
x Bool -> Bool -> Bool
&& Half
x Half -> Half -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x01ff = Word16 -> Half
castWord16ToHalf (Word16 -> Half) -> Word16 -> Half
forall a b. (a -> b) -> a -> b
$ Half -> Word16
forall a b. (RealFrac a, Integral b) => a -> b
round Half
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. 0x7e00
    | Bool
otherwise = 0

  setPayloadSignaling :: Half -> Half
setPayloadSignaling x :: Half
x
    | 0 Half -> Half -> Bool
forall a. Ord a => a -> a -> Bool
< Half
x Bool -> Bool -> Bool
&& Half
x Half -> Half -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x01ff = Word16 -> Half
castWord16ToHalf (Word16 -> Half) -> Word16 -> Half
forall a b. (a -> b) -> a -> b
$ Half -> Word16
forall a b. (RealFrac a, Integral b) => a -> b
round Half
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. 0x7c00
    | Bool
otherwise = 0

  classify :: Half -> Class
classify x :: Half
x =
    let w :: Word16
w = Half -> Word16
castHalfToWord16 Half
x
        s :: Bool
s = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 15
        e :: Word16
e = (Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 10) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x1f -- exponent (5 bits)
        m :: Word16
m = Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0x3ff -- mantissa (10 bits without leading 1)
    in case (Bool
s, Word16
e, Word16
m) of
         (True,  0,    0) -> Class
NegativeZero
         (False, 0,    0) -> Class
PositiveZero
         (True,  0,    _) -> Class
NegativeSubnormal
         (False, 0,    _) -> Class
PositiveSubnormal
         (True,  0x1f, 0) -> Class
NegativeInfinity
         (False, 0x1f, 0) -> Class
PositiveInfinity
         (_,     0x1f, _) -> if Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
w 9 then
                               Class
QuietNaN
                             else
                               Class
SignalingNaN
         (True,  _,    _) -> Class
NegativeNormal
         (False, _,    _) -> Class
PositiveNormal

  equalByTotalOrder :: Half -> Half -> Bool
equalByTotalOrder x :: Half
x y :: Half
y = Half -> Word16
castHalfToWord16 Half
x Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Half -> Word16
castHalfToWord16 Half
y

  compareByTotalOrder :: Half -> Half -> Ordering
compareByTotalOrder x :: Half
x y :: Half
y =
    let x' :: Word16
x' = Half -> Word16
castHalfToWord16 Half
x
        y' :: Word16
y' = Half -> Word16
castHalfToWord16 Half
y
    in Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
y' 15) (Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
x' 15) -- sign bit
       Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> if Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
x' 15 then
            Word16 -> Word16 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word16
y' Word16
x' -- negative
          else
            Word16 -> Word16 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word16
x' Word16
y' -- positive

{-# RULES
"nextUp/Half" nextUp = nextUpHalf
"nextDown/Half" nextDown = nextDownHalf
"nextTowardZero/Half" nextTowardZero = nextTowardZeroHalf
"isNormal/Half" isNormal = isNormalHalf
"isFinite/Half" isFinite = isFiniteHalf
"isZero/Half" isZero = Numeric.Half.isZero
"isSignMinus/Half" isSignMinus = isSignMinusHalf
"classify/Half" classify = classifyHalf
"isMantissaEven/Half" forall (x :: Half).
  isMantissaEven x = even (castHalfToWord16 x)
  #-}

{-# SPECIALIZE minPositive :: Half #-}
{-# SPECIALIZE minPositiveNormal :: Half #-}
{-# SPECIALIZE maxFinite :: Half #-}
{-# SPECIALIZE
  positiveWordToBinaryFloatR# :: RoundingStrategy f => Bool -> Word# -> f Half
                               , Bool -> Word# -> RoundTiesToEven Half
                               , Bool -> Word# -> RoundTiesToAway Half
                               , Bool -> Word# -> RoundTowardPositive Half
                               , Bool -> Word# -> RoundTowardNegative Half
                               , Bool -> Word# -> RoundTowardZero Half
  #-}
{-# SPECIALIZE
  fromPositiveIntegerR :: RoundingStrategy f => Bool -> Integer -> f Half
                        , Bool -> Integer -> RoundTiesToEven Half
                        , Bool -> Integer -> RoundTiesToAway Half
                        , Bool -> Integer -> RoundTowardPositive Half
                        , Bool -> Integer -> RoundTowardNegative Half
                        , Bool -> Integer -> RoundTowardZero Half
  #-}
{-# SPECIALIZE
  fromPositiveRatioR :: RoundingStrategy f => Bool -> Integer -> Integer -> f Half
                      , Bool -> Integer -> Integer -> RoundTiesToEven Half
                      , Bool -> Integer -> Integer -> RoundTiesToAway Half
                      , Bool -> Integer -> Integer -> RoundTowardPositive Half
                      , Bool -> Integer -> Integer -> RoundTowardNegative Half
                      , Bool -> Integer -> Integer -> RoundTowardZero Half
  #-}
{-# SPECIALIZE
  encodePositiveFloatR# :: RoundingStrategy f => Bool -> Integer -> Int# -> f Half
                         , Bool -> Integer -> Int# -> RoundTiesToEven Half
                         , Bool -> Integer -> Int# -> RoundTiesToAway Half
                         , Bool -> Integer -> Int# -> RoundTowardPositive Half
                         , Bool -> Integer -> Int# -> RoundTowardNegative Half
                         , Bool -> Integer -> Int# -> RoundTowardZero Half
  #-}
{-# SPECIALIZE
  scaleFloatR# :: RoundingStrategy f => Int# -> Half -> f Half
                , Int# -> Half -> RoundTiesToEven Half
                , Int# -> Half -> RoundTiesToAway Half
                , Int# -> Half -> RoundTowardPositive Half
                , Int# -> Half -> RoundTowardNegative Half
                , Int# -> Half -> RoundTowardZero Half
  #-}

-- Monomorphic conversion functions
halfToFloat :: Half -> Float
halfToDouble :: Half -> Double
floatToHalf :: Float -> Half
doubleToHalf :: Double -> Half

#if defined(HAS_FAST_HALF_CONVERSION)

foreign import ccall unsafe "hs_fastHalfToFloat"
  c_fastHalfToFloat :: Word16 -> Float
foreign import ccall unsafe "hs_fastHalfToDouble"
  c_fastHalfToDouble :: Word16 -> Double
foreign import ccall unsafe "hs_fastFloatToHalf"
  c_fastFloatToHalf :: Float -> Word16
foreign import ccall unsafe "hs_fastDoubleToHalf"
  c_fastDoubleToHalf :: Double -> Word16

halfToFloat = coerce c_fastHalfToFloat
{-# INLINE halfToFloat #-}

halfToDouble = coerce c_fastHalfToDouble
{-# INLINE halfToDouble #-}

floatToHalf = coerce c_fastFloatToHalf
{-# INLINE floatToHalf #-}

doubleToHalf = coerce c_fastDoubleToHalf
{-# INLINE doubleToHalf #-}

{-# RULES
"realFloatToFrac/Half->Float" realFloatToFrac = halfToFloat
"realFloatToFrac/Half->Double" realFloatToFrac = halfToDouble
"realFloatToFrac/Float->Half" realFloatToFrac = floatToHalf
"realFloatToFrac/Double->Half" realFloatToFrac = doubleToHalf
  #-}

#else

halfToFloat :: Half -> Float
halfToFloat = Half -> Float
fromHalf
{-# INLINE halfToFloat #-}

halfToDouble :: Half -> Double
halfToDouble = Float -> Double
float2Double (Float -> Double) -> (Half -> Float) -> Half -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Half -> Float
fromHalf
{-# INLINE halfToDouble #-}

floatToHalf :: Float -> Half
floatToHalf = Float -> Half
toHalf
{-# INLINE floatToHalf #-}

doubleToHalf :: Double -> Half
doubleToHalf = Double -> Half
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac -- generic implementation
{-# INLINE doubleToHalf #-}

{-# RULES
"realFloatToFrac/Half->Float" realFloatToFrac = fromHalf
"realFloatToFrac/Half->Double" realFloatToFrac = (realFloatToFrac . fromHalf) :: Half -> Double
"realFloatToFrac/Float->Half" realFloatToFrac = toHalf
  #-}

#endif