half 0.3 → 0.3.3
raw patch · 8 files changed
Files
- .travis.yml +0/−113
- CHANGELOG.markdown +18/−0
- README.markdown +1/−1
- Setup.hs +0/−2
- half.cabal +65/−46
- src/Numeric/Half.hs +4/−221
- src/Numeric/Half/Internal.hs +319/−0
- test/Spec.hs +169/−19
− .travis.yml
@@ -1,113 +0,0 @@-language: c-sudo: false--cache:- directories:- - $HOME/.cabsnap- - $HOME/.cabal/packages--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar--matrix:- include:- - env: CABALVER=1.16 GHCVER=7.4.2- compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.16 GHCVER=7.6.3- compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.18 GHCVER=7.8.4- compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.22 GHCVER=7.10.1- compiler: ": #GHC 7.10.1"- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.22 GHCVER=7.10.2- compiler: ": #GHC 7.10.2"- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.2- compiler: ": #GHC 8.0.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.2.2- compiler: ": #GHC 8.2.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=2.0 GHCVER=8.4.1- compiler: ": #GHC 8.4.1"- addons: {apt: {packages: [cabal-install-2.0,ghc-8.4.1,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=head- compiler: ": #GHC head"- addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}--# NOTE: The `primitve` package is currently broken with 8.4.1, remove the line below when this is fixed.- allow_failures:- - env: CABALVER=2.0 GHCVER=8.4.1- - env: CABALVER=head GHCVER=head--before_install:- - unset CC- - export HAPPYVER=1.19.5- - export ALEXVER=3.1.7- - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH--install:- - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];- then- zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >- $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;- fi- - travis_retry cabal update- - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config"- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt--# check whether current requested install-plan matches cached package-db snapshot- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;- then- echo "cabal build-cache HIT";- rm -rfv .ghc;- cp -a $HOME/.cabsnap/ghc $HOME/.ghc;- cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;- else- echo "cabal build-cache MISS";- rm -rf $HOME/.cabsnap;- mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;- cabal install --only-dependencies --enable-tests --enable-benchmarks;- if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi;- fi--# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];- then- echo "snapshotting package-db to build-cache";- mkdir $HOME/.cabsnap;- cp -a $HOME/.ghc $HOME/.cabsnap/ghc;- cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;- fi--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:- - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging- - cabal build # this builds all libraries and executables (including tests)- - cabal test- - cabal bench || true # expected result: these will crash- - cabal sdist || true # tests that a source-distribution can be generated--# Check that the resulting source distribution can be built & installed.-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:-# `cabal install --force-reinstalls dist/*-*.tar.gz`- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&- (cd dist && cabal install --force-reinstalls "$SRC_TGZ")--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313half\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"-# EOF
CHANGELOG.markdown view
@@ -1,3 +1,21 @@+0.3.3 [2025.06.17]+------------------+* Replace `test-framework` with `tasty` in the test suite.++0.3.2 [2024.12.04]+------------------+* Drop support for pre-8.0 versions of GHC.++0.3.1 [2021-01-04]+------------------+* Downgraded testing claims that NaNs will round-trip, as 32-bit GHCs aren't fulfilling that promise.+ Now we merely claim that a NaN will return as a NaN.+* Always provide `NFData Half` instance+* Add `Binary Half` instance+* Explicitly mark module as `Trustworthy`+* Fix `isInfinite`+* Add experimental support for GHCJS, add pure conversion functions.+ 0.3 --- * Fixed bound in `floatRange`.
README.markdown view
@@ -1,7 +1,7 @@ half ==== -[](https://hackage.haskell.org/package/half) [](http://travis-ci.org/ekmett/half)+[](https://hackage.haskell.org/package/half) [](https://github.com/ekmett/half/actions?query=workflow%3AHaskell-CI) This package supplies half-precision floating point values w/ 1 bit of sign, 5 bits of exponent, 11 bits of mantissa trailing a leading 1 bit with proper underflow.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
half.cabal view
@@ -1,55 +1,74 @@-name: half-category: Numeric-version: 0.3-license: BSD3-cabal-version: >= 1.8-license-file: LICENSE-author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>-stability: provisional-homepage: http://github.com/ekmett/half-bug-reports: http://github.com/ekmett/half/issues-copyright: Copyright (C) 2014 Edward A. Kmett-build-type: Simple-synopsis: Half-precision floating-point-description: Half-precision floating-point.-+cabal-version: >=1.10+name: half+version: 0.3.3+license: BSD3+license-file: LICENSE+copyright: Copyright (C) 2014 Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+author: Edward A. Kmett+stability: provisional+homepage: http://github.com/ekmett/half+bug-reports: http://github.com/ekmett/half/issues+synopsis: Half-precision floating-point+description:+ Half-precision floating-point.+category: Numeric+build-type: Simple extra-source-files:- .travis.yml- .gitignore- README.markdown- CHANGELOG.markdown+ .gitignore+ README.markdown+ CHANGELOG.markdown +tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1+ source-repository head- type: git- location: git://github.com/ekmett/half.git+ type: git+ location: https://github.com/ekmett/half.git library- hs-source-dirs: src- c-sources: cbits/half.c- build-depends: base >= 4.3 && < 5- , template-haskell- if impl(ghc >= 7.8)- build-depends: deepseq >= 1.4 && < 1.5- if impl(ghc < 7.6)- build-depends: ghc-prim- ghc-options: -Wall -fwarn-tabs -O2-- if impl(ghc >= 8)- ghc-options: -Wno-missing-pattern-synonym-signatures+ default-language: Haskell2010+ exposed-modules:+ Numeric.Half+ Numeric.Half.Internal+ hs-source-dirs: src+ other-extensions: BangPatterns CPP DeriveDataTypeable DeriveGeneric+ DeriveLift ForeignFunctionInterface PatternSynonyms+ StandaloneDeriving+ ghc-options: -Wall -Wtabs -O2 -Wno-missing-pattern-synonym-signatures+ build-depends:+ base >=4.9 && <5,+ binary >=0.5.1.0 && <0.9,+ deepseq >=1.4.2.0 && <1.6,+ template-haskell >=2.11 - exposed-modules: Numeric.Half+ if !impl(ghcjs)+ c-sources:+ cbits/half.c test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test- ghc-options: -Wall- if impl(ghc >= 7.8)+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ ghc-options: -Wall+ build-depends:- base >= 4.3 && < 5- , half- , hspec >= 2.4- , QuickCheck >= 2.9- else- buildable: False+ base,+ binary,+ bytestring,+ half,+ QuickCheck >=2.14.1 && <2.17,+ tasty >= 1.4 && < 1.6,+ tasty-quickcheck >= 0.10 && < 0.12
src/Numeric/Half.hs view
@@ -1,16 +1,5 @@-{-# 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+{-# LANGUAGE Safe #-}+{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- |@@ -30,7 +19,7 @@ , isZero , fromHalf , toHalf-#if __GLASGOW_HASKELL__ >= 708+ -- * Patterns , pattern POS_INF , pattern NEG_INF , pattern QNaN@@ -42,212 +31,6 @@ , 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)-+import Numeric.Half.Internal
+ src/Numeric/Half/Internal.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2014 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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.Internal+ ( Half(..)+ , isZero+ , fromHalf+ , toHalf+ -- * Patterns+ , 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+ -- * Pure conversions+ , pure_floatToHalf+ , pure_halfToFloat+ ) where++import Control.DeepSeq (NFData (..))+import Data.Bits+import Data.Function (on)+import Data.Int+import Foreign.C.Types (CUShort (..))+import Foreign.Ptr (castPtr)+import Foreign.Storable+import GHC.Generics+import Text.Read (Read (..))++import Language.Haskell.TH.Syntax (Lift (..))++import Data.Binary (Binary (..))++#ifdef __GHCJS__+toHalf :: Float -> Half+toHalf = pure_floatToHalf++fromHalf :: Half -> Float+fromHalf = pure_halfToFloat+#else+-- | 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 #-}+#endif++-- | A half-precision floating point value+newtype+ {-# CTYPE "unsigned short" #-}+ Half = Half { getHalf :: CUShort } deriving Generic++instance NFData Half where+ rnf (Half f) = rnf f++instance Binary Half where+ put (Half (CUShort w)) = put w+ get = fmap (Half . CUShort) get++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)++ isInfinite (Half h) = unsafeShiftR h 10 .&. 0x1f >= 31 && h .&. 0x3ff == 0+ isDenormalized (Half h) = unsafeShiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0+ isNaN (Half h) = unsafeShiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0++ 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++-- | 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++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)) = [| Half (CUShort w) |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped (Half (CUShort w)) = [|| Half (CUShort w) ||]+#endif++-- 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)++-- | Naive pure-Haskell implementation of 'toHalf'.+--+pure_floatToHalf :: Float -> Half+pure_floatToHalf = Half . pure_floatToHalf'++pure_floatToHalf' :: Float -> CUShort+pure_floatToHalf' x | isInfinite x = if x < 0 then 0xfc00 else 0x7c00+pure_floatToHalf' x | isNaN x = 0xfe00+-- for some reason, comparing with 0 and then deciding sign fails with GHC-7.8+pure_floatToHalf' x | isNegativeZero x = 0x8000+pure_floatToHalf' 0 = 0+pure_floatToHalf' x = let+ (m, n) = decodeFloat x+ -- sign bit+ s = if signum m < 0 then 0x8000 else 0+ m1 = fromIntegral $ abs m :: Int+ -- bit len of m1, here m1 /= 0+ len = 1 + snd (foldl (\(acc, res) y -> if acc .&. y == 0+ then (acc, 2*res)+ else (acc .&. y, 2*res + 1))+ (m1, 0)+ [ 0xffff0000, 0xff00ff00ff00, 0xf0f0f0f0+ , 0xcccccccc, 0xaaaaaaaa]+ )+ -- scale to at least 12bit+ (len', m', n') = if len > 11 then (len, m1, n)+ else (12, shiftL m1 (11 - len), n - (11 - len))+ e = n' + len' - 1+ in+ if e > 15 then fromIntegral (s .|. 0x7c00)+ else if e >= -14 then let t' = len' - 11+ m'' = m' + (2 ^ (t' - 1) - 1) ++ (shiftR m' t' .&. 1)+ len'' = if testBit m'' len then len' + 1 else len'+ t'' = len'' - 11+ e'' = n' + len'' - 1+ res = (shiftR m'' t'' .&. 0x3ff) .|.+ shiftL ((e'' + 15) .&. 0x1f) 10 .|.+ s+ in if e'' > 15+ then fromIntegral (s .|. 0x7c00)+ else fromIntegral res+ -- subnormal+ else if e >= -25 then let t = -n' + 1 -11 - 14+ m'' = m' + (2 ^ (t - 1) - 1) ++ (shiftR m' t .&. 1)+ res = shiftR m'' t .|. s+ in if e == -15 && testBit m'' (10 + t)+ then fromIntegral $ (shiftR m'' t .&. 0x3ff) .|.+ 0x400 .|. s+ else fromIntegral res+ else fromIntegral s++-- | Naive pure-Haskell implementation of 'fromHalf'.+pure_halfToFloat :: Half -> Float+pure_halfToFloat = pure_halfToFloat' . getHalf++pure_halfToFloat' :: CUShort -> Float+pure_halfToFloat' 0xfc00 = -1/0+pure_halfToFloat' 0x7c00 = 1/0+pure_halfToFloat' 0x0000 = 0+pure_halfToFloat' 0x8000 = -0+pure_halfToFloat' x | (x .&. 0x7c00 == 0x7c00) && (x .&. 0x3ff /= 0) = 0/0+pure_halfToFloat' x = let+ s = if x .&. 0x8000 /= 0 then -1 else 1+ e = fromIntegral (shiftR x 10) .&. 0x1f :: Int+ m = x .&. 0x3ff+ (a, b) = if e > 0 then (e - 15 - 10, m .|. 0x400)+ else (-15 - 10 + 1, m)+ in encodeFloat (s * fromIntegral b) a
test/Spec.hs view
@@ -1,32 +1,182 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-} -import Numeric.Half-import Test.Hspec-import Test.QuickCheck+import Numeric.Half+import Numeric.Half.Internal+import Test.QuickCheck (Arbitrary (..), Property, counterexample, (===), (==>), property, once)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Foreign.C.Types+import Data.List (sort)+import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as LBS instance Arbitrary Half where arbitrary = fmap Half arbitrary +qnan :: Half+qnan = Half 0x7fff++snan :: Half+snan = Half 0x7dff++pos_inf :: Half+pos_inf = Half 0x7c00++neg_inf :: Half+neg_inf = Half 0xfc00++nans :: [Half]+nans = [qnan, snan]++-- test QNaN, SNaN patterns+ main :: IO ()-main = hspec $ do- describe "Half Ord instance" $ do- it "(>=) is the opposite of (<) except for NaN" $- property $ \x y ->+main = defaultMain $+ testGroup "half"+ [ testGroup "Half Ord instance"+ [ testProperty "(>=) is the opposite of (<) except for NaN" $ \x y -> ((x >= y) /= (x < y)) || isNaN x || isNaN (y :: Half) - let nans = [QNaN, SNaN]+ , testProperty "returns False for NaN > NaN" $+ or [a > b | a <- nans, b <- nans] === False - it "returns False for NaN > NaN" $- or [a > b | a <- nans, b <- nans] `shouldBe` False+ , testProperty "returns False for NaN < NaN" $+ or [a < b | a <- nans, b <- nans] === False - it "returns False for NaN < NaN" $- or [a < b | a <- nans, b <- nans] `shouldBe` False+ ]+ , testGroup "Round trip"+ [ testProperty "should round trip properly" $ \w ->+ if isNaN w+ then property $ isNaN $ toHalf (fromHalf w) -- nans go to nans+ else toHalf (fromHalf w) === w -- everything goes to itself - describe "Round trip" $ do- let roundTrip w = (getHalf . toHalf . fromHalf . Half $ w) == w+ , testProperty "idempotence 1" $ \w ->+ not (isNaN w) ==> fromHalf (toHalf $ fromHalf w) === fromHalf w - it "should round trip properly" $- property roundTrip+ , testProperty "idempotence 2" $ \w ->+ toHalf (fromHalf $ toHalf w) === toHalf w+ ] - it "should round trip for a NaN value" $- roundTrip 0x7d00 `shouldBe` True+ , testGroup "isInfinite"+ [ testProperty "should be equivalent to \\x -> x == POS_INF || x == NEG_INF" $ \x ->+ isInfinite x === (x == pos_inf || x == neg_inf)+ , testProperty "should return True on POS_INF" $+ isInfinite pos_inf === True+ , testProperty "should return True on NEG_INF" $+ isInfinite neg_inf === True+ , testProperty "should return false on QNaN" $+ isInfinite qnan === False+ , testProperty "should return false on SNaN" $+ isInfinite snan === False+ ]++ , testGroup "Patterns"+ [ testProperty "QNaN" $ case qnan of+ QNaN -> True+ _ -> False+ , testProperty "SNaN" $ case snan of+ SNaN -> True+ _ -> False+ , testProperty "POS_INF" $ case pos_inf of+ POS_INF -> True+ _ -> False+ , testProperty "NEG_INF" $ case neg_inf of+ NEG_INF -> True+ _ -> False+ ]++ -- With GHCJS these tests are trivially true.+ , testGroup "Native fromHalf against C version"+ [ testProperty "for full CUShort range, both version of fromHalf should return same Float" $+ once prop_from_half_list+ ]++ , testGroup "Native toHalf against C version"+ [ testProperty "for selected range of Float, both version of toHalf should return same Half" $+ once prop_to_half_list+ ]++ , testGroup "Binary"+ [ testProperty "Binary round trip a" prop_binary_roundtrip_a+ , testProperty "Binary round trip b" prop_binary_roundtrip_b++ -- big endian+ , testProperty "Binary encoding example" $+ Binary.encode neg_inf === LBS.pack [252, 0]+ ]+ ]++-------------------------------------------------------------------------------+-- Binary+-------------------------------------------------------------------------------++prop_binary_roundtrip_a :: Half -> Property+prop_binary_roundtrip_a h = getHalf h === getHalf (Binary.decode (Binary.encode h))++prop_binary_roundtrip_b :: Half -> Property+prop_binary_roundtrip_b h = not (isNaN h) ==> h === Binary.decode (Binary.encode h)++-------------------------------------------------------------------------------+-- Pure conversions+-------------------------------------------------------------------------------++-- test native haskell implementation of toHalf & fromHalf against with C version+prop_from_half :: CUShort -> Bool+prop_from_half i = let+ ref = fromHalf $ Half i+ imp = pure_halfToFloat $ Half i+ in (isNaN ref && isNaN imp) || (ref == imp)++newtype U16List = U16List [CUShort] deriving (Eq, Ord, Show)++instance Arbitrary U16List where+ arbitrary = return (U16List [0 .. 65535])+ shrink (U16List (_ : [])) = []+ shrink (U16List x) = let p = length x `div` 2+ in [U16List $ take p x, U16List $ drop p x]++prop_from_half_list :: U16List -> Bool+prop_from_half_list (U16List l) = all id $ map prop_from_half l++prop_to_half :: Float -> Bool+prop_to_half i = let+ ref = getHalf $ toHalf i+ imp = getHalf $ pure_floatToHalf i+ in (ref == imp) || (isNaN (Half ref) && isNaN (Half imp))++-- cover all range of Half(not Float)+list1 :: [Float]+list1 = let+ r1 = filter (not . isNaN) $ map (fromHalf . Half) [0 .. 65535]+ r2 = sort $ filter (not . isInfinite) $ filter (>= 0) r1+ r3 = r2 ++ [last r2 + 2 ** 11]+ r4 = zipWithTail (\a b -> let d = (b - a) / 4+ in [a, a + d, a + d * 2, a + d * 3])+ r3+ r5 = concat r4 ++ [last r3]+ in r5++zipWithTail :: (a -> a -> b) -> [a] -> [b]+zipWithTail _ [] = []+zipWithTail f xs@(_:xss) = zipWith f xs xss++list2 :: [Float]+list2 = map negate list1++list3 :: [Float]+list3 = [1/0, -1/0, 0, -0, 0/0]+++newtype FloatList = FloatList [Float] deriving (Eq, Ord, Show)++instance Arbitrary FloatList where+ arbitrary = return (FloatList $ list1 ++ list2 ++ list3)+ shrink (FloatList (_ : [])) = []+ shrink (FloatList x) = let p = length x `div` 2+ in [FloatList $ take p x, FloatList $ drop p x]++prop_to_half_list :: FloatList -> Property+prop_to_half_list (FloatList l) = counterexample+ (show [ (getHalf (toHalf f), getHalf (pure_floatToHalf f), f, isNegativeZero f) | f <- take 3 l])+ $ all id $ map prop_to_half l