{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TemplateHaskell #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : PatternSynonyms -- -- Half-precision floating-point values. These arise commonly in GPU work -- and it is useful to be able to compute them and compute with them on the -- CPU as well. ---------------------------------------------------------------------------- module Numeric.Half ( Half(..) , isZero , fromHalf , toHalf #if __GLASGOW_HASKELL__ >= 708 , pattern POS_INF , pattern NEG_INF , pattern QNaN , pattern SNaN , pattern HALF_MIN , pattern HALF_NRM_MIN , pattern HALF_MAX , pattern HALF_EPSILON , pattern HALF_DIG , pattern HALF_MIN_10_EXP , pattern HALF_MAX_10_EXP #endif ) where #if __GLASGOW_HASKELL__ >= 708 import Control.DeepSeq (NFData) #endif import Data.Bits import Data.Function (on) import Data.Int import Data.Typeable import Foreign.C.Types import Foreign.Ptr (castPtr) import Foreign.Storable import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax import Text.Read hiding (lift) -- | Convert a 'Float' to a 'Half' with proper rounding, while preserving NaN and dealing appropriately with infinity foreign import ccall unsafe "hs_floatToHalf" toHalf :: Float -> Half -- {-# RULES "toHalf" realToFrac = toHalf #-} -- | Convert a 'Half' to a 'Float' while preserving NaN foreign import ccall unsafe "hs_halfToFloat" fromHalf :: Half -> Float -- {-# RULES "fromHalf" realToFrac = fromHalf #-} newtype #if __GLASGOW_HASKELL__ >= 706 {-# CTYPE "unsigned short" #-} #endif Half = Half { getHalf :: CUShort } deriving (Generic, Typeable) #if __GLASGOW_HASKELL__ >= 708 instance NFData Half where #endif instance Storable Half where sizeOf = sizeOf . getHalf alignment = alignment . getHalf peek p = fmap Half (peek (castPtr p)) poke p = poke (castPtr p) . getHalf instance Show Half where showsPrec d h = showsPrec d (fromHalf h) instance Read Half where readPrec = fmap toHalf readPrec instance Eq Half where (==) = (==) `on` fromHalf instance Ord Half where compare = compare `on` fromHalf (<) = (<) `on` fromHalf (<=) = (<=) `on` fromHalf (>) = (>) `on` fromHalf (>=) = (>=) `on` fromHalf instance Real Half where toRational = toRational . fromHalf instance Fractional Half where fromRational = toHalf . fromRational recip = toHalf . recip . fromHalf a / b = toHalf $ fromHalf a / fromHalf b instance RealFrac Half where properFraction a = case properFraction (fromHalf a) of (b, c) -> (b, toHalf c) truncate = truncate . fromHalf round = round . fromHalf ceiling = ceiling . fromHalf floor = floor . fromHalf instance Floating Half where pi = toHalf pi exp = toHalf . exp . fromHalf sqrt = toHalf . sqrt . fromHalf log = toHalf . log . fromHalf a ** b = toHalf $ fromHalf a ** fromHalf b logBase a b = toHalf $ logBase (fromHalf a) (fromHalf b) sin = toHalf . sin . fromHalf tan = toHalf . tan . fromHalf cos = toHalf . cos . fromHalf asin = toHalf . asin . fromHalf atan = toHalf . atan . fromHalf acos = toHalf . acos . fromHalf sinh = toHalf . sinh . fromHalf tanh = toHalf . tanh . fromHalf cosh = toHalf . cosh . fromHalf asinh = toHalf . asinh . fromHalf atanh = toHalf . atanh . fromHalf acosh = toHalf . acosh . fromHalf instance RealFloat Half where floatRadix _ = 2 floatDigits _ = 11 decodeFloat = ieee754_f16_decode isIEEE _ = isIEEE (undefined :: Float) atan2 a b = toHalf $ atan2 (fromHalf a) (fromHalf b) #if MIN_VERSION_base(4,5,0) isInfinite (Half h) = unsafeShiftR h 10 .&. 0x1f >= 31 isDenormalized (Half h) = unsafeShiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0 isNaN (Half h) = unsafeShiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0 #else isInfinite (Half h) = shiftR h 10 .&. 0x1f >= 31 isDenormalized (Half h) = shiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0 isNaN (Half h) = shiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0 #endif isNegativeZero (Half h) = h == 0x8000 floatRange _ = (-13,16) encodeFloat i j = toHalf $ encodeFloat i j exponent = exponent . fromHalf significand = toHalf . significand . fromHalf scaleFloat n = toHalf . scaleFloat n . fromHalf -- | Is this 'Half' equal to 0? isZero :: Half -> Bool isZero (Half h) = h .&. 0x7fff == 0 #if __GLASGOW_HASKELL__ >= 708 -- | Positive infinity pattern POS_INF = Half 0x7c00 -- | Negative infinity pattern NEG_INF = Half 0xfc00 -- | Quiet NaN pattern QNaN = Half 0x7fff -- | Signalling NaN pattern SNaN = Half 0x7dff -- | Smallest positive half pattern HALF_MIN = Half 0x0001 -- 5.96046448e-08 -- | Smallest positive normalized half pattern HALF_NRM_MIN = Half 0x0400 -- 6.10351562e-05 -- | Largest positive half pattern HALF_MAX = Half 0x7bff -- 65504.0 -- | Smallest positive e for which half (1.0 + e) != half (1.0) pattern HALF_EPSILON = Half 0x1400 -- 0.00097656 -- | Number of base 10 digits that can be represented without change pattern HALF_DIG = 2 -- Minimum positive integer such that 10 raised to that power is a normalized half pattern HALF_MIN_10_EXP = -4 -- Maximum positive integer such that 10 raised to that power is a normalized half pattern HALF_MAX_10_EXP = 4 #endif instance Num Half where a * b = toHalf (fromHalf a * fromHalf b) a - b = toHalf (fromHalf a - fromHalf b) a + b = toHalf (fromHalf a + fromHalf b) negate (Half a) = Half (xor 0x8000 a) abs = toHalf . abs . fromHalf signum = toHalf . signum . fromHalf fromInteger a = toHalf (fromInteger a) instance Lift Half where lift (Half (CUShort w)) = appE (conE 'Half) . appE (conE 'CUShort) . litE . integerL . fromIntegral $ w -- Adapted from ghc/rts/StgPrimFloat.c -- ieee754_f16_decode :: Half -> (Integer, Int) ieee754_f16_decode (Half (CUShort i)) = let _HHIGHBIT = 0x0400 _HMSBIT = 0x8000 _HMINEXP = ((_HALF_MIN_EXP) - (_HALF_MANT_DIG) - 1) _HALF_MANT_DIG = floatDigits (undefined::Half) (_HALF_MIN_EXP, _HALF_MAX_EXP) = floatRange (undefined::Half) high1 = fromIntegral i high2 = high1 .&. (_HHIGHBIT - 1) exp1 = ((fromIntegral high1 `unsafeShiftR` 10) .&. 0x1F) + _HMINEXP exp2 = exp1 + 1 (high3, exp3) = if exp1 /= _HMINEXP then (high2 .|. _HHIGHBIT, exp1) else let go (!h, !e) = if h .&. _HHIGHBIT /= 0 then go (h `unsafeShiftL` 1, e-1) else (h, e) in go (high2, exp2) high4 = if fromIntegral i < (0 :: Int16) then -high3 else high3 in if high1 .&. complement _HMSBIT == 0 then (0,0) else (high4, exp3)