diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for rounded-hw + +## 0.1.0.0 (2020-06-23) + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright ARATA Mizuki (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of ARATA Mizuki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,75 @@ +# rounded-hw: Rounding control for built-in floating-point types + +This package provides directed rounding and interval arithmetic for built-in floating-point types (i.e. `Float`, `Double`). +Unlike [rounded](https://hackage.haskell.org/package/rounded), this package does not depend on an external C library. + +In addition to `Float` and `Double`, `LongDouble` from [long-double](https://hackage.haskell.org/package/long-double) package is supported on x86. +There is also support for `Float128` from [float128](https://hackage.haskell.org/package/float128) package under a package flag. + +# API overview + +## Controlling the rounding direction + +The type `RoundingMode` represents the four rounding directions. + +The type `Rounded (r :: RoundingMode) a` is a wrapper for `a`, with instances honoring the rounding direction given by `r`. + +```haskell +module Numeric.Rounded.Hardware where + +data RoundingMode + = ToNearest -- ^ Round to the nearest value (IEEE754 roundTiesToEven) + | TowardNegInf -- ^ Round downward (IEEE754 roundTowardNegative) + | TowardInf -- ^ Round upward (IEEE754 roundTowardPositive) + | TowardZero -- ^ Round toward zero (IEEE754 roundTowardZero) + +newtype Rounded (r :: RoundingMode) a = Rounded { getRounded :: a } + +instance ... => Num (Rounded r a) +instance ... => Fractional (Rounded r a) +instance ... => Real (Rounded r a) +instance ... => RealFrac (Rounded r a) +``` + +## Interval arithmetic + +This library also provides basic interval types. See `Numeric.Rounded.Hardware.Interval` and `Numeric.Rounded.Hardware.Interval.NonEmpty`. + +# Usage + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE HexFloatLiterals #-} +import Numeric +import Numeric.Rounded.Hardware + +main = do + putStrLn $ showHFloat (1 + 0x1p-100 :: Double) "" -- -> 0x1p0 + putStrLn $ showHFloat (1 + 0x1p-100 :: Rounded TowardInf Double) "" -- -> 0x1.0000000000001p0 +``` + +# Backends + +There are several options to control the rounding direction. + +* Pure Haskell (via `Rational`) + * Very slow, but does not depend on FFI and therefore can be used on non-native backends. + * This implementation is always available via a newtype in `Numeric.Rounded.Hardware.Backend.ViaRational`. +* C FFI + * One of the technologies below is used: + * C99 (`fesetround`) + * SSE2 (`_mm_setcsr`) + * AVX512 EVEX encoding (`_mm_*_round_*`) + * x87 Control Word (for x87 long double) + * AArch64 FPCR + * On x86_64, `foreign import prim` is used to provide faster interval addition/subtraction. + +By default, C FFI is used and an appropriate technology is detected. +To disable use of C FFI, set `pure-hs` flag when building. + +The name of the backend used can be obtained with `Numeric.Rounded.Hardware.Backend.backendName`. + +```haskell +>>> backendName (Proxy :: Proxy Double) +"FastFFI+SSE2" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,29 @@ +import Distribution.Simple +import Distribution.Simple.Configure (configure) +import Distribution.Simple.PackageIndex (allPackages) +import Distribution.Types.BuildInfo (BuildInfo (includeDirs)) +import qualified Distribution.Types.InstalledPackageInfo as InstalledPackageInfo (includeDirs) +import Distribution.Types.Library (Library (libBuildInfo)) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo (installedPkgs, localPkgDescr)) +import Distribution.Types.PackageDescription (PackageDescription (library)) + +{- +We want to access "ghcconfig.h" from assembly source file (.S), +but GHC does not pass the include directory to the assembler. +So we need to set include-dirs to include the path to "ghcconfig.h" +-} + +main = defaultMainWithHooks simpleUserHooks { confHook = myConfHook } + where + -- myConfHook :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo + myConfHook a cf = do + localBuildInfo <- configure a cf + let extraIncludeDirs :: [String] + extraIncludeDirs = concatMap InstalledPackageInfo.includeDirs (allPackages $ installedPkgs localBuildInfo) + updateBuildInfo :: BuildInfo -> BuildInfo + updateBuildInfo bi = bi { includeDirs = includeDirs bi ++ extraIncludeDirs } + updateLibrary :: Library -> Library + updateLibrary lib = lib { libBuildInfo = updateBuildInfo (libBuildInfo lib) } + updatePkgDescr :: PackageDescription -> PackageDescription + updatePkgDescr pd = pd { library = updateLibrary <$> library pd } + return localBuildInfo { localPkgDescr = updatePkgDescr (localPkgDescr localBuildInfo) } diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE HexFloatLiterals #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +import Conversion +import Data.Coerce +import Data.Functor.Identity +import Data.Int +import Data.Proxy +import Data.Ratio +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Gauge.Main +import IGA +import Numeric +import Numeric.Rounded.Hardware.Internal +import Numeric.Rounded.Hardware.Interval +import Numeric.Rounded.Hardware.Interval.Class (makeInterval) +import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as NE +import qualified Numeric.Rounded.Hardware.Vector.Unboxed as RVU + +foreign import ccall unsafe "nextafter" + c_nextafter_double :: Double -> Double -> Double +foreign import ccall unsafe "nextafterf" + c_nextafter_float :: Float -> Float -> Float +foreign import ccall unsafe "fma" + c_fma_double :: Double -> Double -> Double -> Double +foreign import ccall unsafe "fmaf" + c_fma_float :: Float -> Float -> Float -> Float + +class Fractional a => CFloat a where + c_nextafter :: a -> a -> a + c_fma :: a -> a -> a -> a + +instance CFloat Double where + c_nextafter = c_nextafter_double + c_fma = c_fma_double + +instance CFloat Float where + c_nextafter = c_nextafter_float + c_fma = c_fma_float + +c_nextUp, c_nextDown :: (RealFloat a, CFloat a) => a -> a +c_nextUp x = c_nextafter x (1/0) +c_nextDown x = c_nextafter x (-1/0) + +main :: IO () +main = + defaultMain + [ Conversion.benchmark + , IGA.benchmark + , let vec :: VU.Vector Double + vec = VU.generate 100000 $ \i -> fromRational (1 % fromIntegral (i+1)) + vec1, vec2 :: VU.Vector (Rounded 'TowardInf Double) + vec1 = VU.drop 3 $ VU.take 58645 $ VU.map Rounded vec + vec2 = VU.drop 1234 $ VU.take 78245 $ VU.map Rounded vec + vec3 = VU.drop 123 $ VU.take 78245 $ VU.map Rounded vec + sqrt' :: forall r a. (Rounding r, RoundedSqrt a) => Rounded r a -> Rounded r a + sqrt' (Rounded x) = Rounded (roundedSqrt r x) + where r = rounding (Proxy :: Proxy r) + fma' :: forall r a. (Rounding r, RoundedRing a) => Rounded r a -> Rounded r a -> Rounded r a -> Rounded r a + fma' (Rounded x) (Rounded y) (Rounded z) = Rounded (roundedFusedMultiplyAdd r x y z) + where r = rounding (Proxy :: Proxy r) + uncurry3 f (x, y, z) = f x y z + in bgroup "Vector" + [ bgroup "sum" + [ bench "naive" $ nf VU.sum vec1 + , bench "C impl" $ nf RVU.sum vec1 + , bench "non-rounded" $ nf VU.sum (coerce vec1 :: VU.Vector Double) + ] + , bgroup "add" + [ bench "naive" $ nf (uncurry (VU.zipWith (+))) (vec1, vec2) + , bench "C impl" $ nf (uncurry RVU.zipWith_add) (vec1, vec2) + , bench "non-rounded" $ nf (uncurry (VU.zipWith (+))) (coerce vec1 :: VU.Vector Double, coerce vec2) + ] + , bgroup "sub" + [ bench "naive" $ nf (uncurry (VU.zipWith (-))) (vec1, vec2) + , bench "C impl" $ nf (uncurry RVU.zipWith_sub) (vec1, vec2) + , bench "non-rounded" $ nf (uncurry (VU.zipWith (-))) (coerce vec1 :: VU.Vector Double, coerce vec2) + ] + , bgroup "mul" + [ bench "naive" $ nf (uncurry (VU.zipWith (*))) (vec1, vec2) + , bench "C impl" $ nf (uncurry RVU.zipWith_mul) (vec1, vec2) + , bench "non-rounded" $ nf (uncurry (VU.zipWith (*))) (coerce vec1 :: VU.Vector Double, coerce vec2) + ] + , bgroup "FMA" + [ bench "naive" $ nf (uncurry3 (VU.zipWith3 fma')) (vec1, vec2, vec3) + , bench "C impl" $ nf (uncurry3 RVU.zipWith3_fusedMultiplyAdd) (vec1, vec2, vec3) + , bench "non-rounded" $ nf (uncurry3 (VU.zipWith3 fusedMultiplyAdd)) (coerce vec1 :: VU.Vector Double, coerce vec2, coerce vec3) + ] + , bgroup "div" + [ bench "naive" $ nf (uncurry (VU.zipWith (/))) (vec1, vec2) + , bench "C impl" $ nf (uncurry RVU.zipWith_div) (vec1, vec2) + , bench "non-rounded" $ nf (uncurry (VU.zipWith (/))) (coerce vec1 :: VU.Vector Double, coerce vec2) + ] + , bgroup "sqrt" + [ bench "naive" $ nf (VU.map sqrt') vec1 + , bench "C impl" $ nf RVU.map_sqrt vec1 + , bench "non-rounded" $ nf (VU.map sqrt) (coerce vec1 :: VU.Vector Double) + ] + , bgroup "compound" + [ bench "naive" $ nf (\(v1,v2) -> VU.zipWith (+) (VU.zipWith (*) v1 v2) (VU.map sqrt' v2)) (vec1, vec2) + , bench "C impl" $ nf (\(v1,v2) -> RVU.zipWith_add (RVU.zipWith_mul v1 v2) (RVU.map_sqrt v2)) (vec1, vec2) + , bench "non-rounded" $ nf (\(v1,v2) -> VU.zipWith (+) (VU.zipWith (*) v1 v2) (VU.map sqrt v2)) (coerce vec1 :: VU.Vector Double, coerce vec2) + ] + ] + , let iv1, iv2 :: Interval Double + iv1 = makeInterval (Rounded 1) (Rounded 2) + iv2 = makeInterval (Rounded 15) (Rounded 18) + in bgroup "Interval" + [ bench "add" $ nf (uncurry (+)) (iv1, iv2) + , bench "sub" $ nf (uncurry (-)) (iv1, iv2) + , bench "mul" $ nf (uncurry (*)) (iv1, iv2) + , bench "div" $ nf (uncurry (/)) (iv1, iv2) + , bench "sqrt" $ nf sqrt iv1 + , bench "fromInteger" $ nf (fromInteger :: Integer -> Interval Double) (2^60 + 1) + , bench "fromIntegral/Int64" $ nf (fromIntegral :: Int64 -> Interval Double) (2^60 + 1) + ] + , let vec :: V.Vector (Interval Double) + vec = V.generate 100000 $ \i -> fromRational (1 % (1 + fromIntegral i)) + in bgroup "interval sum" + [ bench "naive" $ nf V.sum vec + , bench "naive 2" $ nf (V.foldl' (+) 0) vec + ] + , bgroup "interval elementary functions" + [ bench "exp" $ nf exp (0.3 :: Interval Double) + , bench "NE.exp" $ nf exp (0.3 :: NE.Interval Double) + , bench "sin" $ nf sin (7.3 :: Interval Double) + , bench "NE.sin" $ nf sin (7.3 :: NE.Interval Double) + ] + , bgroup "nextUp" + [ let cases = [0,1,0x1.ffff_ffff_ffff_fp200] :: [Double] + in bgroup "Double" + [ bgroup "C" + [ bench (showHFloat x "") $ nf c_nextUp x | x <- cases ] + , bgroup "Haskell" + [ bench (showHFloat x "") $ nf nextUp x | x <- cases ] + , bgroup "Haskell (generic)" + [ bench (showHFloat x "") $ nf nextUp (Identity x) | x <- cases ] + ] + , let cases = [0,1,0x1.fffffep100] :: [Float] + in bgroup "Float" + [ bgroup "C" + [ bench (showHFloat x "") $ nf c_nextUp x | x <- cases ] + , bgroup "Haskell" + [ bench (showHFloat x "") $ nf nextUp x | x <- cases ] + , bgroup "Haskell (generic)" + [ bench (showHFloat x "") $ nf nextUp (Identity x) | x <- cases ] + ] + ] + , bgroup "nextDown" + [ let cases = [0,1,0x1.ffff_ffff_ffff_fp200] :: [Double] + in bgroup "Double" + [ bgroup "C" + [ bench (showHFloat x "") $ nf c_nextDown x | x <- cases ] + , bgroup "Haskell" + [ bench (showHFloat x "") $ nf nextDown x | x <- cases ] + , bgroup "Haskell (generic)" + [ bench (showHFloat x "") $ nf nextDown (Identity x) | x <- cases ] + ] + , let cases = [0,1,0x1.fffffep100] :: [Float] + in bgroup "Float" + [ bgroup "C" + [ bench (showHFloat x "") $ nf c_nextDown x | x <- cases ] + , bgroup "Haskell" + [ bench (showHFloat x "") $ nf nextDown x | x <- cases ] + , bgroup "Haskell (generic)" + [ bench (showHFloat x "") $ nf nextDown (Identity x) | x <- cases ] + ] + ] + , bgroup "FMA" + [ let arg = (1.0, 2.0, 3.0) :: (Double, Double, Double) + in bgroup "Double" + [ bench "C" $ nf (\(x,y,z) -> c_fma x y z) arg + , bench "Haskell" $ nf (\(x,y,z) -> fusedMultiplyAdd x y z) arg + , bench "Haskell (generic)" $ nf (\(x,y,z) -> fusedMultiplyAdd (Identity x) (Identity y) (Identity z)) arg + , bench "Haskell (rounded)" $ nf (\(x,y,z) -> roundedFusedMultiplyAdd ToNearest x y z) arg + , bench "non-fused" $ nf (\(x,y,z) -> x * y + z) arg + ] + , let arg = (1.0, 2.0, 3.0) :: (Float, Float, Float) + in bgroup "Float" + [ bench "C" $ nf (\(x,y,z) -> c_fma x y z) arg + , bench "Haskell" $ nf (\(x,y,z) -> fusedMultiplyAdd x y z) arg + , bench "Haskell (generic)" $ nf (\(x,y,z) -> fusedMultiplyAdd (Identity x) (Identity y) (Identity z)) arg + , bench "Haskell (rounded)" $ nf (\(x,y,z) -> roundedFusedMultiplyAdd ToNearest x y z) arg + , bench "non-fused" $ nf (\(x,y,z) -> x * y + z) arg + ] + ] + ] diff --git a/benchmark/Conversion.hs b/benchmark/Conversion.hs new file mode 100644 --- /dev/null +++ b/benchmark/Conversion.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE HexFloatLiterals #-} +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +module Conversion (benchmark) where +import Data.Bits +import Data.Int +import Data.Ratio +import Data.Word +import Gauge.Benchmark +import Numeric.Rounded.Hardware +import Numeric.Rounded.Hardware.Class +import Numeric.Rounded.Hardware.Interval + +word64ToDouble :: RoundingMode -> Word64 -> Double +word64ToDouble ToNearest x + | x >= 0xFFFF_FFFF_FFFF_FC00 = 0x1p64 + | otherwise = let z = countLeadingZeros x + y = if x .&. (0x0000_0000_0000_0800 `unsafeShiftR` z) == 0 + then x + (0x0000_0000_0000_03FF `unsafeShiftR` z) + else x + (0x0000_0000_0000_0400 `unsafeShiftR` z) + in fromIntegral (y .&. (0xFFFF_FFFF_FFFF_F800 `unsafeShiftR` z)) +word64ToDouble TowardInf x + | x >= 0xFFFF_FFFF_FFFF_F800 = 0x1p64 + | otherwise = let z = countLeadingZeros x + y = x + (0x0000_0000_0000_07FF `unsafeShiftR` z) + in fromIntegral (y .&. (0xFFFF_FFFF_FFFF_F800 `unsafeShiftR` z)) +word64ToDouble TowardNegInf x = let z = countLeadingZeros x + in fromIntegral (x .&. (0xFFFF_FFFF_FFFF_F800 `unsafeShiftR` z)) +word64ToDouble TowardZero x = let z = countLeadingZeros x + in fromIntegral (x .&. (0xFFFF_FFFF_FFFF_F800 `unsafeShiftR` z)) + +int64ToDouble :: RoundingMode -> Int64 -> Double +int64ToDouble r x | x >= 0 = word64ToDouble r (fromIntegral x) + | r == TowardInf = - word64ToDouble TowardNegInf (fromIntegral (-x)) + | r == TowardNegInf = - word64ToDouble TowardInf (fromIntegral (-x)) + | otherwise = - word64ToDouble r (fromIntegral (-x)) + +benchmark :: Benchmark +benchmark = bgroup "Conversion" + [ let smallInteger = -2^50+2^13+127 :: Integer + mediumInteger = -2^60 + 42 * 2^53 - 137 * 2^24 + 3 :: Integer + largeInteger = -2^100-37*2^80+2^13+127 :: Integer + in bgroup "fromInteger" + [ bench "Double/small" $ nf (fromInteger :: Integer -> Double) smallInteger + , bench "Double/medium" $ nf (fromInteger :: Integer -> Double) mediumInteger + , bench "Double/large" $ nf (fromInteger :: Integer -> Double) largeInteger + , bench "RoundedDouble/ToNearest/small" $ nf (fromInteger :: Integer -> Rounded 'ToNearest Double) smallInteger + , bench "RoundedDouble/ToNearest/medium" $ nf (fromInteger :: Integer -> Rounded 'ToNearest Double) mediumInteger + , bench "RoundedDouble/ToNearest/large" $ nf (fromInteger :: Integer -> Rounded 'ToNearest Double) largeInteger + , bench "RoundedDouble/TowardInf/small" $ nf (fromInteger :: Integer -> Rounded 'TowardInf Double) smallInteger + , bench "RoundedDouble/TowardInf/medium" $ nf (fromInteger :: Integer -> Rounded 'TowardInf Double) mediumInteger + , bench "RoundedDouble/TowardInf/large" $ nf (fromInteger :: Integer -> Rounded 'TowardInf Double) largeInteger + , bench "roundedFromInteger/Double/ToNearest/small" $ nf (roundedFromInteger ToNearest :: Integer -> Double) smallInteger + , bench "roundedFromInteger/Double/ToNearest/medium" $ nf (roundedFromInteger ToNearest :: Integer -> Double) mediumInteger + , bench "roundedFromInteger/Double/ToNearest/large" $ nf (roundedFromInteger ToNearest :: Integer -> Double) largeInteger + , bench "roundedFromInteger/Double/TowardInf/small" $ nf (roundedFromInteger TowardInf :: Integer -> Double) smallInteger + , bench "roundedFromInteger/Double/TowardInf/medium" $ nf (roundedFromInteger TowardInf :: Integer -> Double) mediumInteger + , bench "roundedFromInteger/Double/TowardInf/large" $ nf (roundedFromInteger TowardInf :: Integer -> Double) largeInteger + , bench "IntervalDouble/small" $ nf (fromInteger :: Integer -> Interval Double) smallInteger + , bench "IntervalDouble/medium" $ nf (fromInteger :: Integer -> Interval Double) mediumInteger + , bench "IntervalDouble/large" $ nf (fromInteger :: Integer -> Interval Double) largeInteger + ] + , let smallInteger = -2^50+2^13+127 :: Int64 + mediumInteger = -2^60 + 42 * 2^53 - 137 * 2^24 + 3 :: Int64 + in bgroup "fromIntegral/Int64" + [ bench "Double/small" $ nf (fromIntegral :: Int64 -> Double) smallInteger + , bench "Double/medium" $ nf (fromIntegral :: Int64 -> Double) mediumInteger + , bench "RoundedDouble/ToNearest/small" $ nf (fromIntegral :: Int64 -> Rounded 'ToNearest Double) smallInteger + , bench "RoundedDouble/ToNearest/medium" $ nf (fromIntegral :: Int64 -> Rounded 'ToNearest Double) mediumInteger + , bench "RoundedDouble/TowardInf/small" $ nf (fromIntegral :: Int64 -> Rounded 'TowardInf Double) smallInteger + , bench "RoundedDouble/TowardInf/medium" $ nf (fromIntegral :: Int64 -> Rounded 'TowardInf Double) mediumInteger + , bench "roundedFromInteger/Double/ToNearest/small" $ nf (roundedFromInteger ToNearest . fromIntegral :: Int64 -> Double) smallInteger + , bench "roundedFromInteger/Double/ToNearest/medium" $ nf (roundedFromInteger ToNearest . fromIntegral :: Int64 -> Double) mediumInteger + , bench "roundedFromInteger/Double/TowardInf/small" $ nf (roundedFromInteger TowardInf . fromIntegral :: Int64 -> Double) smallInteger + , bench "roundedFromInteger/Double/TowardInf/medium" $ nf (roundedFromInteger TowardInf . fromIntegral :: Int64 -> Double) mediumInteger + , bench "int64ToDouble/Double/ToNearest/small" $ nf (int64ToDouble ToNearest :: Int64 -> Double) smallInteger + , bench "int64ToDouble/Double/ToNearest/medium" $ nf (int64ToDouble ToNearest :: Int64 -> Double) mediumInteger + , bench "int64ToDouble/Double/TowardInf/small" $ nf (int64ToDouble TowardInf :: Int64 -> Double) smallInteger + , bench "int64ToDouble/Double/TowardInf/medium" $ nf (int64ToDouble TowardInf :: Int64 -> Double) mediumInteger + ] + , let pi' = 3.14159265358979323846264338327950 :: Rational + smallRational = 22 % 7 :: Rational + largeRational = 78326489123342523452342137498719847192 % 348912374981749170413424213275017 :: Rational + in bgroup "fromRational" + [ bench "Double/decimal" $ nf (fromRational :: Rational -> Double) pi' + , bench "Double/small" $ nf (fromRational :: Rational -> Double) smallRational + , bench "Double/large" $ nf (fromRational :: Rational -> Double) largeRational + , bench "RoundedDouble/ToNearest/decimal" $ nf (fromRational :: Rational -> Rounded 'ToNearest Double) pi' + , bench "RoundedDouble/ToNearest/small" $ nf (fromRational :: Rational -> Rounded 'ToNearest Double) smallRational + , bench "RoundedDouble/ToNearest/large" $ nf (fromRational :: Rational -> Rounded 'ToNearest Double) largeRational + , bench "RoundedDouble/TowardInf/decimal" $ nf (fromRational :: Rational -> Rounded 'TowardInf Double) pi' + , bench "RoundedDouble/TowardInf/small" $ nf (fromRational :: Rational -> Rounded 'TowardInf Double) smallRational + , bench "RoundedDouble/TowardInf/large" $ nf (fromRational :: Rational -> Rounded 'TowardInf Double) largeRational + , bench "IntervalDouble/decimal" $ nf (fromRational :: Rational -> Interval Double) pi' + , bench "IntervalDouble/small" $ nf (fromRational :: Rational -> Interval Double) smallRational + , bench "IntervalDouble/large" $ nf (fromRational :: Rational -> Interval Double) largeRational + ] + ] diff --git a/benchmark/IGA.hs b/benchmark/IGA.hs new file mode 100644 --- /dev/null +++ b/benchmark/IGA.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuantifiedConstraints #-} +module IGA (benchmark) where +import Control.Monad +import Control.Monad.ST +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.ST (STArray, STUArray) +import Data.Array.Unboxed (UArray) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Gauge.Benchmark +import Numeric.Rounded.Hardware.Interval +import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as NE + +thawST :: (Ix i, IArray a e) => a i e -> ST s (STArray s i e) +thawST = thaw + +thawSTU :: (Ix i, IArray a e {-, MArray (STUArray s) e (ST s) -}) => a i e -> ST s (STArray s i e) +thawSTU = thaw +{-# INLINE thawSTU #-} + +intervalGaussianElimination :: (Fractional a) => Array (Int,Int) a -> V.Vector a -> V.Vector a +intervalGaussianElimination a b + | not (i0 == 0 && j0 == 0 && iN == n - 1 && jN == n - 1) = error "invalid size" + | otherwise = V.create $ do + a' <- thawST a + b' <- V.thaw b + + -- elimination + forM_ [0..n-2] $ \k -> do + forM_ [k+1..n-1] $ \i -> do + !t <- liftM2 (/) (readArray a' (i,k)) (readArray a' (k,k)) + forM_ [k+1..n-1] $ \j -> do + a_ij <- readArray a' (i,j) + a_kj <- readArray a' (k,j) + writeArray a' (i,j) $! a_ij - t * a_kj + b_k <- VM.read b' k + modify' b' (subtract (t * b_k)) i + + -- backward substitution + a_nn <- readArray a' (n-1,n-1) + modify' b' (/ a_nn) (n-1) + forM_ [n-2,n-3..0] $ \i -> do + s <- sum <$> mapM (\j -> liftM2 (*) (readArray a' (i,j)) (VM.read b' j)) [i+1..n-1] + a_ii <- readArray a' (i,i) + modify' b' (\b_i -> (b_i - s) / a_ii) i + return b' + where + ((i0,j0),(iN,jN)) = bounds a + n = V.length b + modify' vec f i = do + x <- VM.read vec i + VM.write vec i $! f x + +{-# SPECIALIZE + intervalGaussianEliminationU :: UArray (Int,Int) Double -> VU.Vector Double -> VU.Vector Double, UArray (Int,Int) (Interval Double) -> VU.Vector (Interval Double) -> VU.Vector (Interval Double) + , UArray (Int,Int) (NE.Interval Double) -> VU.Vector (NE.Interval Double) -> VU.Vector (NE.Interval Double) + #-} +intervalGaussianEliminationU :: (Fractional a, IArray UArray a, forall s. MArray (STUArray s) a (ST s), VU.Unbox a) => UArray (Int,Int) a -> VU.Vector a -> VU.Vector a +intervalGaussianEliminationU a b + | not (i0 == 0 && j0 == 0 && iN == n - 1 && jN == n - 1) = error "invalid size" + | otherwise = VU.create $ do + a' <- thawSTU a + b' <- VU.thaw b + + -- elimination + forM_ [0..n-2] $ \k -> do + forM_ [k+1..n-1] $ \i -> do + !t <- liftM2 (/) (readArray a' (i,k)) (readArray a' (k,k)) + forM_ [k+1..n-1] $ \j -> do + a_ij <- readArray a' (i,j) + a_kj <- readArray a' (k,j) + writeArray a' (i,j) $! a_ij - t * a_kj + b_k <- VUM.read b' k + modify' b' (subtract (t * b_k)) i + + -- backward substitution + a_nn <- readArray a' (n-1,n-1) + modify' b' (/ a_nn) (n-1) + forM_ [n-2,n-3..0] $ \i -> do + s <- sum <$> mapM (\j -> liftM2 (*) (readArray a' (i,j)) (VUM.read b' j)) [i+1..n-1] + a_ii <- readArray a' (i,i) + modify' b' (\b_i -> (b_i - s) / a_ii) i + return b' + where + ((i0,j0),(iN,jN)) = bounds a + n = VU.length b + modify' vec f i = do + x <- VUM.read vec i + VUM.write vec i $! f x + +benchmark :: Benchmark +benchmark = bgroup "Interval Gaussian Elimination" + [ let arr :: Fractional a => Array (Int,Int) a + arr = listArray ((0,0),(4,4)) + [2,4,1,3,8 + ,-4,7,3.1,0,7 + ,9,7,54,1,0,1 + ,0,5,8,1e-10,7 + ,8,6,4,8,0 + ] + vec :: Fractional a => V.Vector a + vec = V.fromList [1,0,0,0,0] + in bgroup "boxed" + [ bench "non-interval" $ nf (uncurry intervalGaussianElimination) (arr, vec :: V.Vector Double) + , bench "naive" $ nf (uncurry intervalGaussianElimination) (arr, vec :: V.Vector (Interval Double)) + , bench "non-empty" $ nf (uncurry intervalGaussianElimination) (arr, vec :: V.Vector (NE.Interval Double)) + ] + , let arr :: (IArray UArray a, Fractional a) => UArray (Int,Int) a + arr = listArray ((0,0),(4,4)) + [2,4,1,3,8 + ,-4,7,3.1,0,7 + ,9,7,54,1,0,1 + ,0,5,8,1e-10,7 + ,8,6,4,8,0 + ] + vec :: (VU.Unbox a, Fractional a) => VU.Vector a + vec = VU.fromList [1,0,0,0,0] + in bgroup "unboxed" + [ bench "non-interval" $ nf (uncurry intervalGaussianEliminationU) (arr, vec :: VU.Vector Double) + , bench "naive" $ nf (uncurry intervalGaussianEliminationU) (arr, vec :: VU.Vector (Interval Double)) + , bench "non-empty" $ nf (uncurry intervalGaussianEliminationU) (arr, vec :: VU.Vector (NE.Interval Double)) + ] + ] diff --git a/cbits/interval-prim-x86_64-avx512.S b/cbits/interval-prim-x86_64-avx512.S new file mode 100644 --- /dev/null +++ b/cbits/interval-prim-x86_64-avx512.S @@ -0,0 +1,111 @@ +/* NB: We need some tricks to include "ghcconfig.h" from assembly source files. See Setup.hs for details. */ +#include "ghcconfig.h" +#if LEADING_UNDERSCORE +#define SYMBOL2(name) _##name +#define SYMBOL(name) SYMBOL2(name) +#else +#define SYMBOL(name) name +#endif + + .globl SYMBOL(rounded_hw_interval_backend_name) +SYMBOL(rounded_hw_interval_backend_name): + .string "AVX512" + + # + # rounded_hw_interval_add + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> Double# -- lower 2 (%xmm3) + # -> Double# -- upper 2 (%xmm4) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_add) +SYMBOL(rounded_hw_interval_add): + vaddsd {rd-sae}, %xmm3, %xmm1, %xmm1 # xmm1 = xmm1[0] + xmm3[0], xmm1[1] (downward) + vaddsd {ru-sae}, %xmm4, %xmm2, %xmm2 # xmm2 = xmm2[0] + xmm4[0], xmm2[1] (downward) + jmp *(%rbp) + + # + # rounded_hw_interval_sub + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> Double# -- lower 2 (%xmm3) + # -> Double# -- upper 2 (%xmm4) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_sub) +SYMBOL(rounded_hw_interval_sub): + vsubsd {rd-sae}, %xmm4, %xmm1, %xmm1 # xmm1 = xmm1[0] - xmm4[0], xmm1[1] (downward) + vsubsd {ru-sae}, %xmm3, %xmm2, %xmm2 # xmm2 = xmm2[0] - xmm3[0], xmm2[1] (upward) + jmp *(%rbp) + + # + # rounded_hw_interval_recip + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_recip) +SYMBOL(rounded_hw_interval_recip): + vmovsd LC0(%rip), %xmm4 # xmm4 = 1.0, zero + vdivsd {rd-sae}, %xmm2, %xmm4, %xmm3 # xmm3 = xmm4[0] / xmm2[0], xmm4[1] (downward) + vdivsd {ru-sae}, %xmm1, %xmm4, %xmm2 # xmm2 = xmm4[0] / xmm1[0], xmm4[1] (upward) + vmovapd %xmm3, %xmm1 # xmm1 = xmm3 + jmp *(%rbp) +LC0: + .quad 0x3FF0000000000000 # 1.0 in binary64 + # 0b0011_1111_1111_0000_..._0000 + # ^^----+------^ ^-----+-----^ + # | | +-- trailing significand field + # | +-- biased exponent + # +-- sign + + # + # rounded_hw_interval_sqrt + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_sqrt) +SYMBOL(rounded_hw_interval_sqrt): + vmovq %xmm1, %xmm1 # xmm1 = xmm1[0], zero + vsqrtsd {rd-sae}, %xmm1, %xmm1, %xmm1 # xmm1 = sqrt(xmm1[0]), xmm1[1] (downward) + vmovq %xmm2, %xmm2 # xmm2 = xmm2[0], zero + vsqrtsd {ru-sae}, %xmm2, %xmm2, %xmm2 # xmm2 = sqrt(xmm2[0]), xmm2[1] (upward) + jmp *(%rbp) + + # + # rounded_hw_interval_from_int64 + # :: Int(64)# -- input (%rbx) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_from_int64) +SYMBOL(rounded_hw_interval_from_int64): + vxorps %xmm2, %xmm2, %xmm2 # xmm2 = zero + vcvtsi2sdq %rbx, {rd-sae}, %xmm2, %xmm1 # xmm1 = (double)(int64)rbx, xmm2[1] (downward) + vcvtsi2sdq %rbx, {ru-sae}, %xmm2, %xmm2 # xmm2 = (double)(int64)rbx, xmm2[1] (upward) + jmp *(%rbp) + + # + # rounded_hw_interval_from_word64 + # :: Word(64)# -- input (%rbx) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_from_word64) +SYMBOL(rounded_hw_interval_from_word64): + vxorps %xmm2, %xmm2, %xmm2 # xmm2 = zero + vcvtusi2sdq %rbx, {rd-sae}, %xmm2, %xmm1 # xmm1 = (double)(uint64)rbx, xmm2[1] (downward) + vcvtusi2sdq %rbx, {ru-sae}, %xmm2, %xmm2 # xmm2 = (double)(uint64)rbx, xmm2[1] (upward) + jmp *(%rbp) diff --git a/cbits/interval-prim-x86_64-sse2.S b/cbits/interval-prim-x86_64-sse2.S new file mode 100644 --- /dev/null +++ b/cbits/interval-prim-x86_64-sse2.S @@ -0,0 +1,148 @@ +/* NB: We need some tricks to include "ghcconfig.h" from assembly source files. See Setup.hs for details. */ +#include "ghcconfig.h" +#if LEADING_UNDERSCORE +#define SYMBOL2(name) _##name +#define SYMBOL(name) SYMBOL2(name) +#else +#define SYMBOL(name) name +#endif + + .globl SYMBOL(rounded_hw_interval_backend_name) +SYMBOL(rounded_hw_interval_backend_name): + .string "SSE2" + + # + # rounded_hw_interval_add + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> Double# -- lower 2 (%xmm3) + # -> Double# -- upper 2 (%xmm4) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_add) +SYMBOL(rounded_hw_interval_add): + stmxcsr -8(%rbp) # *(int32*)(rbp-8) = MXCSR + movl -8(%rbp), %ecx # ecx = *(int32*)(rbp-8) + andl $0x9FFF, %ecx # ecx = ecx & 0x9FFF; clear Rounding Control field + orl $0x2000, %ecx # ecx = ecx | 0x2000; set RC = downward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4) + addsd %xmm3, %xmm1 # xmm1 = xmm1[0] + xmm3[0], xmm1[1] + xorl $0x6000, %ecx # ecx = ecx ^ 0x6000; downward -> upward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4) + addsd %xmm4, %xmm2 # xmm2 = xmm2[0] + xmm4[0], xmm2[1] + ldmxcsr -8(%rbp) # MXCSR = *(int32*)(rbp-8) + jmp *(%rbp) + + # + # rounded_hw_interval_sub + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> Double# -- lower 2 (%xmm3) + # -> Double# -- upper 2 (%xmm4) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_sub) +SYMBOL(rounded_hw_interval_sub): + stmxcsr -8(%rbp) # *(int32*)(rbp-8) = MXCSR + movl -8(%rbp), %ecx # ecx = *(int32*)(rbp-8) + andl $0x9FFF, %ecx # ecx = ecx & 0x9FFF; clear Rounding Control field + orl $0x2000, %ecx # ecx = ecx | 0x2000; set RC = downward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4) + subsd %xmm4, %xmm1 # xmm1 = xmm1[0] - xmm4[0], xmm1[1] + xorl $0x6000, %ecx # ecx = ecx ^ 0x6000; downward -> upward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4) + subsd %xmm3, %xmm2 # xmm2 = xmm2[0] - xmm3[0], xmm2[1] + ldmxcsr -8(%rbp) # MXCSR = *(int32*)(rbp-4) + jmp *(%rbp) + + # + # rounded_hw_interval_recip + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_recip) +SYMBOL(rounded_hw_interval_recip): + stmxcsr -8(%rbp) # *(int32*)(rbp-8) = MXCSR + movl -8(%rbp), %ecx # ecx = *(int32*)(rbp-8) + andl $0x9FFF, %ecx # ecx = ecx & 0x9FFF; clear Rounding Control field + orl $0x2000, %ecx # ecx = ecx | 0x2000; set RC = downward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set downward + movsd LC0(%rip), %xmm3 # xmm3 = (double)1.0,zero + movapd %xmm3, %xmm4 # xmm4 = xmm3 + divsd %xmm2, %xmm3 # xmm3 = xmm3[0] / xmm2[0], xmm3[1] + xorl $0x6000, %ecx # ecx = ecx ^ 0x6000; downward -> upward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set upward + divsd %xmm1, %xmm4 # xmm4 = xmm4[0] / xmm1[0], xmm4[1] + ldmxcsr -8(%rbp) # MXCSR = *(int32*)(rbp-8); restore + movapd %xmm3, %xmm1 # xmm1 = xmm3 + movapd %xmm4, %xmm2 # xmm2 = xmm4 + jmp *(%rbp) +LC0: + .quad 0x3FF0000000000000 # 1.0 in binary64 + # 0b0011_1111_1111_0000_..._0000 + # ^^----+------^ ^-----+-----^ + # | | +-- trailing significand field + # | +-- biased exponent + # +-- sign + + # + # rounded_hw_interval_sqrt + # :: Double# -- lower 1 (%xmm1) + # -> Double# -- upper 1 (%xmm2) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_sqrt) +SYMBOL(rounded_hw_interval_sqrt): + stmxcsr -8(%rbp) # *(int32*)(rbp-8) = MXCSR + movl -8(%rbp), %ecx # ecx = *(int32*)(rbp-8) + andl $0x9FFF, %ecx # ecx = ecx & 0x9FFF; clear Rounding Control field + orl $0x2000, %ecx # ecx = ecx | 0x2000; set RC = downward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set downward + sqrtsd %xmm1, %xmm1 # xmm1 = sqrt(xmm1[0]), xmm1[1] + xorl $0x6000, %ecx # ecx = ecx ^ 0x6000; downward -> upward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set upward + sqrtsd %xmm2, %xmm2 # xmm2 = sqrt(xmm2[0]), xmm2[1] + ldmxcsr -8(%rbp) # MXCSR = *(int32*)(rbp-8); restore + jmp *(%rbp) + + # + # rounded_hw_interval_from_int64 + # :: Int(64)# -- input (%rbx) + # -> (# Double# -- lower (%xmm1) + # , Double# -- upper (%xmm2) + # #) + # + .globl SYMBOL(rounded_hw_interval_from_int64) +SYMBOL(rounded_hw_interval_from_int64): + stmxcsr -8(%rbp) # *(int32*)(rbp-8) = MXCSR + movl -8(%rbp), %ecx # ecx = *(int32*)(rbp-8) + andl $0x9FFF, %ecx # ecx = ecx & 0x9FFF; clear Rounding Control field + orl $0x2000, %ecx # ecx = ecx | 0x2000; set RC = downward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set downward + pxor %xmm1, %xmm1 # xmm1 = zero + cvtsi2sdq %rbx, %xmm1 # xmm1 = (double)(int64)rbx, xmm1[1] + xorl $0x6000, %ecx # ecx = ecx ^ 0x6000; downward -> upward + movl %ecx, -4(%rbp) # *(int32*)(rbp-4) = ecx + ldmxcsr -4(%rbp) # MXCSR = *(int32*)(rbp-4); set upward + pxor %xmm2, %xmm2 # xmm2 = zero + cvtsi2sdq %rbx, %xmm2 # xmm2 = (double)(int64)rbx, xmm2[1] + ldmxcsr -8(%rbp) # MXCSR = *(int32*)(rbp-8); restore + jmp *(%rbp) diff --git a/cbits/interval-prim-x86_64.S b/cbits/interval-prim-x86_64.S new file mode 100644 --- /dev/null +++ b/cbits/interval-prim-x86_64.S @@ -0,0 +1,5 @@ +#ifdef __AVX512F__ +#include "interval-prim-x86_64-avx512.S" +#else +#include "interval-prim-x86_64-sse2.S" +#endif diff --git a/cbits/rounded-avx512.inl b/cbits/rounded-avx512.inl new file mode 100644 --- /dev/null +++ b/cbits/rounded-avx512.inl @@ -0,0 +1,1311 @@ +/* This file was generated by etc/gen-rounded-avx512.sh. */ + +// +// double +// + +static inline ALWAYS_INLINE +double rounded_add_impl_double(native_rounding_mode mode, double a, double b) +{ + __m128d av = _mm_set_sd(a); + __m128d bv = _mm_set_sd(b); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_add_round_sd(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_add_round_sd(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_add_round_sd(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_add_round_sd(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_add_double(HsInt mode, double a, double b) +{ return rounded_add_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_add_double_up(double a, double b) +{ return rounded_add_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_add_double_down(double a, double b) +{ return rounded_add_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_add_double_zero(double a, double b) +{ return rounded_add_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +double rounded_sub_impl_double(native_rounding_mode mode, double a, double b) +{ + __m128d av = _mm_set_sd(a); + __m128d bv = _mm_set_sd(b); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_sub_round_sd(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_sub_round_sd(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_sub_round_sd(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_sub_round_sd(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_sub_double(HsInt mode, double a, double b) +{ return rounded_sub_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_sub_double_up(double a, double b) +{ return rounded_sub_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_sub_double_down(double a, double b) +{ return rounded_sub_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_sub_double_zero(double a, double b) +{ return rounded_sub_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +double rounded_mul_impl_double(native_rounding_mode mode, double a, double b) +{ + __m128d av = _mm_set_sd(a); + __m128d bv = _mm_set_sd(b); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_mul_round_sd(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_mul_round_sd(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_mul_round_sd(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_mul_round_sd(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_mul_double(HsInt mode, double a, double b) +{ return rounded_mul_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_mul_double_up(double a, double b) +{ return rounded_mul_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_mul_double_down(double a, double b) +{ return rounded_mul_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_mul_double_zero(double a, double b) +{ return rounded_mul_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +double rounded_div_impl_double(native_rounding_mode mode, double a, double b) +{ + __m128d av = _mm_set_sd(a); + __m128d bv = _mm_set_sd(b); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_div_round_sd(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_div_round_sd(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_div_round_sd(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_div_round_sd(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_div_double(HsInt mode, double a, double b) +{ return rounded_div_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_div_double_up(double a, double b) +{ return rounded_div_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_div_double_down(double a, double b) +{ return rounded_div_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_div_double_zero(double a, double b) +{ return rounded_div_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +double rounded_sqrt_impl_double(native_rounding_mode mode, double a) +{ + __m128d av = _mm_set_sd(a); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_sqrt_round_sd(av, av, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_sqrt_round_sd(av, av, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_sqrt_round_sd(av, av, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_sqrt_round_sd(av, av, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_sqrt_double(HsInt mode, double a) +{ return rounded_sqrt_impl_double(hs_rounding_mode_to_native(mode), a); } +extern double rounded_hw_sqrt_double_up(double a) +{ return rounded_sqrt_impl_double(ROUND_UPWARD, a); } +extern double rounded_hw_sqrt_double_down(double a) +{ return rounded_sqrt_impl_double(ROUND_DOWNWARD, a); } +extern double rounded_hw_sqrt_double_zero(double a) +{ return rounded_sqrt_impl_double(ROUND_TOWARDZERO, a); } + +static inline ALWAYS_INLINE +double rounded_fma_impl_double(native_rounding_mode mode, double a, double b, double c) +{ + __m128d av = _mm_set_sd(a); + __m128d bv = _mm_set_sd(b); + __m128d cv = _mm_set_sd(c); + __m128d resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_fmadd_round_sd(av, bv, cv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_fmadd_round_sd(av, bv, cv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_fmadd_round_sd(av, bv, cv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_fmadd_round_sd(av, bv, cv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_fma_double(HsInt mode, double a, double b, double c) +{ return rounded_fma_impl_double(hs_rounding_mode_to_native(mode), a, b, c); } +extern double rounded_hw_fma_double_up(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_UPWARD, a, b, c); } +extern double rounded_hw_fma_double_down(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_DOWNWARD, a, b, c); } +extern double rounded_hw_fma_double_zero(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_TOWARDZERO, a, b, c); } + +extern double rounded_hw_fma_if_fast_double(HsInt mode, double a, double b, double c) +{ return rounded_fma_impl_double(hs_rounding_mode_to_native(mode), a, b, c); } +extern double rounded_hw_fma_if_fast_double_up(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_UPWARD, a, b, c); } +extern double rounded_hw_fma_if_fast_double_down(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_DOWNWARD, a, b, c); } +extern double rounded_hw_fma_if_fast_double_zero(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_TOWARDZERO, a, b, c); } + +// +// Conversion +// + +static inline double rounded_int64_to_double_impl(native_rounding_mode mode, int64_t x) +{ + __m128d resultv = _mm_set_sd(0.0); + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_cvt_roundi64_sd(resultv, x, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_cvt_roundi64_sd(resultv, x, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_cvt_roundi64_sd(resultv, x, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_cvt_roundi64_sd(resultv, x, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_int64_to_double(HsInt mode, int64_t x) +{ return rounded_int64_to_double_impl(hs_rounding_mode_to_native(mode), x); } +extern double rounded_hw_int64_to_double_up(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_UPWARD, x); } +extern double rounded_hw_int64_to_double_down(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_DOWNWARD, x); } +extern double rounded_hw_int64_to_double_zero(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_TOWARDZERO, x); } + +static inline double rounded_word64_to_double_impl(native_rounding_mode mode, uint64_t x) +{ + __m128d resultv = _mm_set_sd(0.0); + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_cvt_roundu64_sd(resultv, x, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_cvt_roundu64_sd(resultv, x, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_cvt_roundu64_sd(resultv, x, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_cvt_roundu64_sd(resultv, x, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + double result; + _mm_store_sd(&result, resultv); + return result; +} +extern double rounded_hw_word64_to_double(HsInt mode, uint64_t x) +{ return rounded_word64_to_double_impl(hs_rounding_mode_to_native(mode), x); } +extern double rounded_hw_word64_to_double_up(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_UPWARD, x); } +extern double rounded_hw_word64_to_double_down(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_DOWNWARD, x); } +extern double rounded_hw_word64_to_double_zero(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_TOWARDZERO, x); } + +// +// Interval arithmetic +// + +static inline double fast_fmax_double(double x, double y) +{ + // should compile to MAX[SP][SD] instruction on x86 + return x > y ? x : y; +} +static inline double fast_fmax4_double(double x, double y, double z, double w) +{ + return fast_fmax_double(fast_fmax_double(x, y), fast_fmax_double(z, w)); +} +static inline double fast_fmin_double(double x, double y) +{ + // should compile to MIN[SP][SD] instruction on x86 + return x < y ? x : y; +} +static inline double fast_fmin4_double(double x, double y, double z, double w) +{ + return fast_fmin_double(fast_fmin_double(x, y), fast_fmin_double(z, w)); +} + +extern double rounded_hw_interval_mul_double_up(double lo1, double hi1, double lo2, double hi2) +{ + double x = rounded_mul_impl_double(ROUND_UPWARD, lo1, lo2); + double y = rounded_mul_impl_double(ROUND_UPWARD, lo1, hi2); + double z = rounded_mul_impl_double(ROUND_UPWARD, hi1, lo2); + double w = rounded_mul_impl_double(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + return fast_fmax4_double(x, y, z, w); +} + +extern double rounded_hw_interval_mul_double_down(double lo1, double hi1, double lo2, double hi2) +{ + double x = rounded_mul_impl_double(ROUND_DOWNWARD, lo1, lo2); + double y = rounded_mul_impl_double(ROUND_DOWNWARD, lo1, hi2); + double z = rounded_mul_impl_double(ROUND_DOWNWARD, hi1, lo2); + double w = rounded_mul_impl_double(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + return fast_fmin4_double(x, y, z, w); +} + +extern double rounded_hw_interval_mul_add_double_up(double lo1, double hi1, double lo2, double hi2, double hi3) +{ + double x = rounded_mul_impl_double(ROUND_UPWARD, lo1, lo2); + double y = rounded_mul_impl_double(ROUND_UPWARD, lo1, hi2); + double z = rounded_mul_impl_double(ROUND_UPWARD, hi1, lo2); + double w = rounded_mul_impl_double(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + double p = fast_fmax4_double(x, y, z, w); + return rounded_add_impl_double(ROUND_UPWARD, p, hi3); +} + +extern double rounded_hw_interval_mul_add_double_down(double lo1, double hi1, double lo2, double hi2, double lo3) +{ + double x = rounded_mul_impl_double(ROUND_DOWNWARD, lo1, lo2); + double y = rounded_mul_impl_double(ROUND_DOWNWARD, lo1, hi2); + double z = rounded_mul_impl_double(ROUND_DOWNWARD, hi1, lo2); + double w = rounded_mul_impl_double(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + double p = fast_fmin4_double(x, y, z, w); + return rounded_add_impl_double(ROUND_DOWNWARD, p, lo3); +} + +extern double rounded_hw_interval_div_double_up(double lo1, double hi1, double lo2, double hi2) +{ + double x = rounded_div_impl_double(ROUND_UPWARD, lo1, lo2); + double y = rounded_div_impl_double(ROUND_UPWARD, lo1, hi2); + double z = rounded_div_impl_double(ROUND_UPWARD, hi1, lo2); + double w = rounded_div_impl_double(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + return fast_fmax4_double(x, y, z, w); +} + +extern double rounded_hw_interval_div_double_down(double lo1, double hi1, double lo2, double hi2) +{ + double x = rounded_div_impl_double(ROUND_DOWNWARD, lo1, lo2); + double y = rounded_div_impl_double(ROUND_DOWNWARD, lo1, hi2); + double z = rounded_div_impl_double(ROUND_DOWNWARD, hi1, lo2); + double w = rounded_div_impl_double(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + return fast_fmin4_double(x, y, z, w); +} + +extern double rounded_hw_interval_div_add_double_up(double lo1, double hi1, double lo2, double hi2, double hi3) +{ + double x = rounded_div_impl_double(ROUND_UPWARD, lo1, lo2); + double y = rounded_div_impl_double(ROUND_UPWARD, lo1, hi2); + double z = rounded_div_impl_double(ROUND_UPWARD, hi1, lo2); + double w = rounded_div_impl_double(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + double p = fast_fmax4_double(x, y, z, w); + return rounded_add_impl_double(ROUND_UPWARD, p, hi3); +} + +extern double rounded_hw_interval_div_add_double_down(double lo1, double hi1, double lo2, double hi2, double lo3) +{ + double x = rounded_div_impl_double(ROUND_DOWNWARD, lo1, lo2); + double y = rounded_div_impl_double(ROUND_DOWNWARD, lo1, hi2); + double z = rounded_div_impl_double(ROUND_DOWNWARD, hi1, lo2); + double w = rounded_div_impl_double(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + double p = fast_fmin4_double(x, y, z, w); + return rounded_add_impl_double(ROUND_DOWNWARD, p, lo3); +} + +// +// Vector Operations +// + +extern double rounded_hw_vector_sum_double(HsInt mode, HsInt length, HsInt offset, const double *a) +{ + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + { + double s = 0.0; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_double(ROUND_TONEAREST, s, a[offset + i]); + } + return s; + } + case ROUND_DOWNWARD: + { + double s = 0.0; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_double(ROUND_DOWNWARD, s, a[offset + i]); + } + return s; + } + case ROUND_UPWARD: + { + double s = 0.0; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_double(ROUND_UPWARD, s, a[offset + i]); + } + return s; + } + case ROUND_TOWARDZERO: + { + double s = 0.0; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_double(ROUND_TOWARDZERO, s, a[offset + i]); + } + return s; + } + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_add_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_double(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_double(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_double(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_double(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_sub_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_double(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_double(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_double(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_double(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_mul_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_double(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_double(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_double(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_double(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_fma_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b, HsInt offsetC, const double * restrict c) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_double(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_double(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_double(ROUND_UPWARD, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_double(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_div_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_double(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_double(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_double(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_double(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_sqrt_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_double(ROUND_TONEAREST, a[offsetA + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_double(ROUND_DOWNWARD, a[offsetA + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_double(ROUND_UPWARD, a[offsetA + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_double(ROUND_TOWARDZERO, a[offsetA + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +// +// float +// + +static inline ALWAYS_INLINE +float rounded_add_impl_float(native_rounding_mode mode, float a, float b) +{ + __m128 av = _mm_set_ss(a); + __m128 bv = _mm_set_ss(b); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_add_round_ss(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_add_round_ss(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_add_round_ss(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_add_round_ss(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_add_float(HsInt mode, float a, float b) +{ return rounded_add_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_add_float_up(float a, float b) +{ return rounded_add_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_add_float_down(float a, float b) +{ return rounded_add_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_add_float_zero(float a, float b) +{ return rounded_add_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +float rounded_sub_impl_float(native_rounding_mode mode, float a, float b) +{ + __m128 av = _mm_set_ss(a); + __m128 bv = _mm_set_ss(b); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_sub_round_ss(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_sub_round_ss(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_sub_round_ss(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_sub_round_ss(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_sub_float(HsInt mode, float a, float b) +{ return rounded_sub_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_sub_float_up(float a, float b) +{ return rounded_sub_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_sub_float_down(float a, float b) +{ return rounded_sub_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_sub_float_zero(float a, float b) +{ return rounded_sub_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +float rounded_mul_impl_float(native_rounding_mode mode, float a, float b) +{ + __m128 av = _mm_set_ss(a); + __m128 bv = _mm_set_ss(b); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_mul_round_ss(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_mul_round_ss(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_mul_round_ss(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_mul_round_ss(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_mul_float(HsInt mode, float a, float b) +{ return rounded_mul_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_mul_float_up(float a, float b) +{ return rounded_mul_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_mul_float_down(float a, float b) +{ return rounded_mul_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_mul_float_zero(float a, float b) +{ return rounded_mul_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +float rounded_div_impl_float(native_rounding_mode mode, float a, float b) +{ + __m128 av = _mm_set_ss(a); + __m128 bv = _mm_set_ss(b); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_div_round_ss(av, bv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_div_round_ss(av, bv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_div_round_ss(av, bv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_div_round_ss(av, bv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_div_float(HsInt mode, float a, float b) +{ return rounded_div_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_div_float_up(float a, float b) +{ return rounded_div_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_div_float_down(float a, float b) +{ return rounded_div_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_div_float_zero(float a, float b) +{ return rounded_div_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline ALWAYS_INLINE +float rounded_sqrt_impl_float(native_rounding_mode mode, float a) +{ + __m128 av = _mm_set_ss(a); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_sqrt_round_ss(av, av, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_sqrt_round_ss(av, av, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_sqrt_round_ss(av, av, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_sqrt_round_ss(av, av, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_sqrt_float(HsInt mode, float a) +{ return rounded_sqrt_impl_float(hs_rounding_mode_to_native(mode), a); } +extern float rounded_hw_sqrt_float_up(float a) +{ return rounded_sqrt_impl_float(ROUND_UPWARD, a); } +extern float rounded_hw_sqrt_float_down(float a) +{ return rounded_sqrt_impl_float(ROUND_DOWNWARD, a); } +extern float rounded_hw_sqrt_float_zero(float a) +{ return rounded_sqrt_impl_float(ROUND_TOWARDZERO, a); } + +static inline ALWAYS_INLINE +float rounded_fma_impl_float(native_rounding_mode mode, float a, float b, float c) +{ + __m128 av = _mm_set_ss(a); + __m128 bv = _mm_set_ss(b); + __m128 cv = _mm_set_ss(c); + __m128 resultv; + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_fmadd_round_ss(av, bv, cv, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_fmadd_round_ss(av, bv, cv, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_fmadd_round_ss(av, bv, cv, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_fmadd_round_ss(av, bv, cv, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_fma_float(HsInt mode, float a, float b, float c) +{ return rounded_fma_impl_float(hs_rounding_mode_to_native(mode), a, b, c); } +extern float rounded_hw_fma_float_up(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_UPWARD, a, b, c); } +extern float rounded_hw_fma_float_down(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_DOWNWARD, a, b, c); } +extern float rounded_hw_fma_float_zero(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_TOWARDZERO, a, b, c); } + +extern float rounded_hw_fma_if_fast_float(HsInt mode, float a, float b, float c) +{ return rounded_fma_impl_float(hs_rounding_mode_to_native(mode), a, b, c); } +extern float rounded_hw_fma_if_fast_float_up(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_UPWARD, a, b, c); } +extern float rounded_hw_fma_if_fast_float_down(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_DOWNWARD, a, b, c); } +extern float rounded_hw_fma_if_fast_float_zero(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_TOWARDZERO, a, b, c); } + +// +// Conversion +// + +static inline float rounded_int64_to_float_impl(native_rounding_mode mode, int64_t x) +{ + __m128 resultv = _mm_set_ss(0.0f); + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_cvt_roundi64_ss(resultv, x, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_cvt_roundi64_ss(resultv, x, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_cvt_roundi64_ss(resultv, x, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_cvt_roundi64_ss(resultv, x, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_int64_to_float(HsInt mode, int64_t x) +{ return rounded_int64_to_float_impl(hs_rounding_mode_to_native(mode), x); } +extern float rounded_hw_int64_to_float_up(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_UPWARD, x); } +extern float rounded_hw_int64_to_float_down(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_DOWNWARD, x); } +extern float rounded_hw_int64_to_float_zero(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_TOWARDZERO, x); } + +static inline float rounded_word64_to_float_impl(native_rounding_mode mode, uint64_t x) +{ + __m128 resultv = _mm_set_ss(0.0f); + switch (mode) { + case ROUND_TONEAREST: + resultv = _mm_cvt_roundu64_ss(resultv, x, _MM_FROUND_TO_NEAREST_INT | _MM_FROUND_NO_EXC); + break; + case ROUND_DOWNWARD: + resultv = _mm_cvt_roundu64_ss(resultv, x, _MM_FROUND_TO_NEG_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_UPWARD: + resultv = _mm_cvt_roundu64_ss(resultv, x, _MM_FROUND_TO_POS_INF | _MM_FROUND_NO_EXC); + break; + case ROUND_TOWARDZERO: + resultv = _mm_cvt_roundu64_ss(resultv, x, _MM_FROUND_TO_ZERO | _MM_FROUND_NO_EXC); + break; + default: + UNREACHABLE(); + abort(); + } + float result; + _mm_store_ss(&result, resultv); + return result; +} +extern float rounded_hw_word64_to_float(HsInt mode, uint64_t x) +{ return rounded_word64_to_float_impl(hs_rounding_mode_to_native(mode), x); } +extern float rounded_hw_word64_to_float_up(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_UPWARD, x); } +extern float rounded_hw_word64_to_float_down(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_DOWNWARD, x); } +extern float rounded_hw_word64_to_float_zero(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_TOWARDZERO, x); } + +// +// Interval arithmetic +// + +static inline float fast_fmax_float(float x, float y) +{ + // should compile to MAX[SP][SD] instruction on x86 + return x > y ? x : y; +} +static inline float fast_fmax4_float(float x, float y, float z, float w) +{ + return fast_fmax_float(fast_fmax_float(x, y), fast_fmax_float(z, w)); +} +static inline float fast_fmin_float(float x, float y) +{ + // should compile to MIN[SP][SD] instruction on x86 + return x < y ? x : y; +} +static inline float fast_fmin4_float(float x, float y, float z, float w) +{ + return fast_fmin_float(fast_fmin_float(x, y), fast_fmin_float(z, w)); +} + +extern float rounded_hw_interval_mul_float_up(float lo1, float hi1, float lo2, float hi2) +{ + float x = rounded_mul_impl_float(ROUND_UPWARD, lo1, lo2); + float y = rounded_mul_impl_float(ROUND_UPWARD, lo1, hi2); + float z = rounded_mul_impl_float(ROUND_UPWARD, hi1, lo2); + float w = rounded_mul_impl_float(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + return fast_fmax4_float(x, y, z, w); +} + +extern float rounded_hw_interval_mul_float_down(float lo1, float hi1, float lo2, float hi2) +{ + float x = rounded_mul_impl_float(ROUND_DOWNWARD, lo1, lo2); + float y = rounded_mul_impl_float(ROUND_DOWNWARD, lo1, hi2); + float z = rounded_mul_impl_float(ROUND_DOWNWARD, hi1, lo2); + float w = rounded_mul_impl_float(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + return fast_fmin4_float(x, y, z, w); +} + +extern float rounded_hw_interval_mul_add_float_up(float lo1, float hi1, float lo2, float hi2, float hi3) +{ + float x = rounded_mul_impl_float(ROUND_UPWARD, lo1, lo2); + float y = rounded_mul_impl_float(ROUND_UPWARD, lo1, hi2); + float z = rounded_mul_impl_float(ROUND_UPWARD, hi1, lo2); + float w = rounded_mul_impl_float(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + float p = fast_fmax4_float(x, y, z, w); + return rounded_add_impl_float(ROUND_UPWARD, p, hi3); +} + +extern float rounded_hw_interval_mul_add_float_down(float lo1, float hi1, float lo2, float hi2, float lo3) +{ + float x = rounded_mul_impl_float(ROUND_DOWNWARD, lo1, lo2); + float y = rounded_mul_impl_float(ROUND_DOWNWARD, lo1, hi2); + float z = rounded_mul_impl_float(ROUND_DOWNWARD, hi1, lo2); + float w = rounded_mul_impl_float(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + float p = fast_fmin4_float(x, y, z, w); + return rounded_add_impl_float(ROUND_DOWNWARD, p, lo3); +} + +extern float rounded_hw_interval_div_float_up(float lo1, float hi1, float lo2, float hi2) +{ + float x = rounded_div_impl_float(ROUND_UPWARD, lo1, lo2); + float y = rounded_div_impl_float(ROUND_UPWARD, lo1, hi2); + float z = rounded_div_impl_float(ROUND_UPWARD, hi1, lo2); + float w = rounded_div_impl_float(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + return fast_fmax4_float(x, y, z, w); +} + +extern float rounded_hw_interval_div_float_down(float lo1, float hi1, float lo2, float hi2) +{ + float x = rounded_div_impl_float(ROUND_DOWNWARD, lo1, lo2); + float y = rounded_div_impl_float(ROUND_DOWNWARD, lo1, hi2); + float z = rounded_div_impl_float(ROUND_DOWNWARD, hi1, lo2); + float w = rounded_div_impl_float(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + return fast_fmin4_float(x, y, z, w); +} + +extern float rounded_hw_interval_div_add_float_up(float lo1, float hi1, float lo2, float hi2, float hi3) +{ + float x = rounded_div_impl_float(ROUND_UPWARD, lo1, lo2); + float y = rounded_div_impl_float(ROUND_UPWARD, lo1, hi2); + float z = rounded_div_impl_float(ROUND_UPWARD, hi1, lo2); + float w = rounded_div_impl_float(ROUND_UPWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + float p = fast_fmax4_float(x, y, z, w); + return rounded_add_impl_float(ROUND_UPWARD, p, hi3); +} + +extern float rounded_hw_interval_div_add_float_down(float lo1, float hi1, float lo2, float hi2, float lo3) +{ + float x = rounded_div_impl_float(ROUND_DOWNWARD, lo1, lo2); + float y = rounded_div_impl_float(ROUND_DOWNWARD, lo1, hi2); + float z = rounded_div_impl_float(ROUND_DOWNWARD, hi1, lo2); + float w = rounded_div_impl_float(ROUND_DOWNWARD, hi1, hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + float p = fast_fmin4_float(x, y, z, w); + return rounded_add_impl_float(ROUND_DOWNWARD, p, lo3); +} + +// +// Vector Operations +// + +extern float rounded_hw_vector_sum_float(HsInt mode, HsInt length, HsInt offset, const float *a) +{ + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + { + float s = 0.0f; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_float(ROUND_TONEAREST, s, a[offset + i]); + } + return s; + } + case ROUND_DOWNWARD: + { + float s = 0.0f; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_float(ROUND_DOWNWARD, s, a[offset + i]); + } + return s; + } + case ROUND_UPWARD: + { + float s = 0.0f; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_float(ROUND_UPWARD, s, a[offset + i]); + } + return s; + } + case ROUND_TOWARDZERO: + { + float s = 0.0f; + for (HsInt i = 0; i < length; ++i) { + s = rounded_add_impl_float(ROUND_TOWARDZERO, s, a[offset + i]); + } + return s; + } + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_add_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_float(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_float(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_float(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_add_impl_float(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_sub_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_float(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_float(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_float(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sub_impl_float(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_mul_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_float(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_float(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_float(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_mul_impl_float(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_fma_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b, HsInt offsetC, const float * restrict c) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_float(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_float(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_float(ROUND_UPWARD, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_fma_impl_float(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_div_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_float(ROUND_TONEAREST, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_float(ROUND_DOWNWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_float(ROUND_UPWARD, a[offsetA + i], b[offsetB + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_div_impl_float(ROUND_TOWARDZERO, a[offsetA + i], b[offsetB + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} + +extern void rounded_hw_vector_sqrt_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a) +{ + // TODO: Use SIMD + switch (hs_rounding_mode_to_native(mode)) { + case ROUND_TONEAREST: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_float(ROUND_TONEAREST, a[offsetA + i]); + } + break; + case ROUND_DOWNWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_float(ROUND_DOWNWARD, a[offsetA + i]); + } + break; + case ROUND_UPWARD: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_float(ROUND_UPWARD, a[offsetA + i]); + } + break; + case ROUND_TOWARDZERO: + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = rounded_sqrt_impl_float(ROUND_TOWARDZERO, a[offsetA + i]); + } + break; + default: + UNREACHABLE(); + abort(); + } +} diff --git a/cbits/rounded-common.inl b/cbits/rounded-common.inl new file mode 100644 --- /dev/null +++ b/cbits/rounded-common.inl @@ -0,0 +1,815 @@ +/* This file was generated by etc/gen-rounded-common.sh. */ + +// +// double +// + +static inline double rounded_add_impl_double(native_rounding_mode mode, double a, double b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double c = a + b; + restore_fp_reg(oldreg); + return c; +} +extern double rounded_hw_add_double(HsInt mode, double a, double b) +{ return rounded_add_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_add_double_up(double a, double b) +{ return rounded_add_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_add_double_down(double a, double b) +{ return rounded_add_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_add_double_zero(double a, double b) +{ return rounded_add_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline double rounded_sub_impl_double(native_rounding_mode mode, double a, double b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double c = a - b; + restore_fp_reg(oldreg); + return c; +} +extern double rounded_hw_sub_double(HsInt mode, double a, double b) +{ return rounded_sub_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_sub_double_up(double a, double b) +{ return rounded_sub_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_sub_double_down(double a, double b) +{ return rounded_sub_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_sub_double_zero(double a, double b) +{ return rounded_sub_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline double rounded_mul_impl_double(native_rounding_mode mode, double a, double b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double c = a * b; + restore_fp_reg(oldreg); + return c; +} +extern double rounded_hw_mul_double(HsInt mode, double a, double b) +{ return rounded_mul_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_mul_double_up(double a, double b) +{ return rounded_mul_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_mul_double_down(double a, double b) +{ return rounded_mul_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_mul_double_zero(double a, double b) +{ return rounded_mul_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline double rounded_div_impl_double(native_rounding_mode mode, double a, double b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double c = a / b; + restore_fp_reg(oldreg); + return c; +} +extern double rounded_hw_div_double(HsInt mode, double a, double b) +{ return rounded_div_impl_double(hs_rounding_mode_to_native(mode), a, b); } +extern double rounded_hw_div_double_up(double a, double b) +{ return rounded_div_impl_double(ROUND_UPWARD, a, b); } +extern double rounded_hw_div_double_down(double a, double b) +{ return rounded_div_impl_double(ROUND_DOWNWARD, a, b); } +extern double rounded_hw_div_double_zero(double a, double b) +{ return rounded_div_impl_double(ROUND_TOWARDZERO, a, b); } + +static inline double rounded_sqrt_impl_double(native_rounding_mode mode, double a) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double c = sqrt(a); + restore_fp_reg(oldreg); + return c; +} +extern double rounded_hw_sqrt_double(HsInt mode, double a) +{ return rounded_sqrt_impl_double(hs_rounding_mode_to_native(mode), a); } +extern double rounded_hw_sqrt_double_up(double a) +{ return rounded_sqrt_impl_double(ROUND_UPWARD, a); } +extern double rounded_hw_sqrt_double_down(double a) +{ return rounded_sqrt_impl_double(ROUND_DOWNWARD, a); } +extern double rounded_hw_sqrt_double_zero(double a) +{ return rounded_sqrt_impl_double(ROUND_TOWARDZERO, a); } + +static inline double rounded_fma_impl_double(native_rounding_mode mode, double a, double b, double c) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double result = fma(a, b, c); + restore_fp_reg(oldreg); + return result; +} +extern double rounded_hw_fma_double(HsInt mode, double a, double b, double c) +{ return rounded_fma_impl_double(hs_rounding_mode_to_native(mode), a, b, c); } +extern double rounded_hw_fma_double_up(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_UPWARD, a, b, c); } +extern double rounded_hw_fma_double_down(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_DOWNWARD, a, b, c); } +extern double rounded_hw_fma_double_zero(double a, double b, double c) +{ return rounded_fma_impl_double(ROUND_TOWARDZERO, a, b, c); } + +static inline double rounded_fma_if_fast_impl_double(native_rounding_mode mode, double a, double b, double c) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); +#ifdef FP_FAST_FMA + volatile double result = fma(a, b, c); +#else + volatile double result = a * b + c; +#endif + restore_fp_reg(oldreg); + return result; +} +extern double rounded_hw_fma_if_fast_double(HsInt mode, double a, double b, double c) +{ return rounded_fma_if_fast_impl_double(hs_rounding_mode_to_native(mode), a, b, c); } +extern double rounded_hw_fma_if_fast_double_up(double a, double b, double c) +{ return rounded_fma_if_fast_impl_double(ROUND_UPWARD, a, b, c); } +extern double rounded_hw_fma_if_fast_double_down(double a, double b, double c) +{ return rounded_fma_if_fast_impl_double(ROUND_DOWNWARD, a, b, c); } +extern double rounded_hw_fma_if_fast_double_zero(double a, double b, double c) +{ return rounded_fma_if_fast_impl_double(ROUND_TOWARDZERO, a, b, c); } + +// +// Conversion +// + +static inline double rounded_int64_to_double_impl(native_rounding_mode mode, int64_t x) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double result = (double)x; + restore_fp_reg(oldreg); + return result; +} +extern double rounded_hw_int64_to_double(HsInt mode, int64_t x) +{ return rounded_int64_to_double_impl(hs_rounding_mode_to_native(mode), x); } +extern double rounded_hw_int64_to_double_up(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_UPWARD, x); } +extern double rounded_hw_int64_to_double_down(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_DOWNWARD, x); } +extern double rounded_hw_int64_to_double_zero(int64_t x) +{ return rounded_int64_to_double_impl(ROUND_TOWARDZERO, x); } + +static inline double rounded_word64_to_double_impl(native_rounding_mode mode, uint64_t x) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile double result = (double)x; + restore_fp_reg(oldreg); + return result; +} +extern double rounded_hw_word64_to_double(HsInt mode, uint64_t x) +{ return rounded_word64_to_double_impl(hs_rounding_mode_to_native(mode), x); } +extern double rounded_hw_word64_to_double_up(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_UPWARD, x); } +extern double rounded_hw_word64_to_double_down(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_DOWNWARD, x); } +extern double rounded_hw_word64_to_double_zero(uint64_t x) +{ return rounded_word64_to_double_impl(ROUND_TOWARDZERO, x); } + +// +// Interval arithmetic +// + +static inline double fast_fmax_double(double x, double y) +{ + // should compile to MAX[SP][SD] instruction on x86 + return x > y ? x : y; +} +static inline double fast_fmax4_double(double x, double y, double z, double w) +{ + return fast_fmax_double(fast_fmax_double(x, y), fast_fmax_double(z, w)); +} +static inline double fast_fmin_double(double x, double y) +{ + // should compile to MIN[SP][SD] instruction on x86 + return x < y ? x : y; +} +static inline double fast_fmin4_double(double x, double y, double z, double w) +{ + return fast_fmin_double(fast_fmin_double(x, y), fast_fmin_double(z, w)); +} + +extern double rounded_hw_interval_mul_double_up(double lo1, double hi1, double lo2, double hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + double x = (volatile double)(lo1 * lo2); + double y = (volatile double)(lo1 * hi2); + double z = (volatile double)(hi1 * lo2); + double w = (volatile double)(hi1 * hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + double hi = fast_fmax4_double(x, y, z, w); + restore_fp_reg(oldreg); + return hi; +} + +extern double rounded_hw_interval_mul_double_down(double lo1, double hi1, double lo2, double hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + double x = (volatile double)(lo1 * lo2); + double y = (volatile double)(lo1 * hi2); + double z = (volatile double)(hi1 * lo2); + double w = (volatile double)(hi1 * hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + double lo = fast_fmin4_double(x, y, z, w); + restore_fp_reg(oldreg); + return lo; +} + +extern double rounded_hw_interval_mul_add_double_up(double lo1, double hi1, double lo2, double hi2, double hi3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + double x = (volatile double)(lo1 * lo2); + double y = (volatile double)(lo1 * hi2); + double z = (volatile double)(hi1 * lo2); + double w = (volatile double)(hi1 * hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + volatile double hi = fast_fmax4_double(x, y, z, w) + hi3; + restore_fp_reg(oldreg); + return hi; +} + +extern double rounded_hw_interval_mul_add_double_down(double lo1, double hi1, double lo2, double hi2, double lo3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + double x = (volatile double)(lo1 * lo2); + double y = (volatile double)(lo1 * hi2); + double z = (volatile double)(hi1 * lo2); + double w = (volatile double)(hi1 * hi2); + if (isnan(x)) x = 0.0; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 * inf -> 0 */ + volatile double lo = fast_fmin4_double(x, y, z, w) + lo3; + restore_fp_reg(oldreg); + return lo; +} + +extern double rounded_hw_interval_div_double_up(double lo1, double hi1, double lo2, double hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + double x = (volatile double)(lo1 / lo2); + double y = (volatile double)(lo1 / hi2); + double z = (volatile double)(hi1 / lo2); + double w = (volatile double)(hi1 / hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + double hi = fast_fmax4_double(x, y, z, w); + restore_fp_reg(oldreg); + return hi; +} + +extern double rounded_hw_interval_div_double_down(double lo1, double hi1, double lo2, double hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + double x = (volatile double)(lo1 / lo2); + double y = (volatile double)(lo1 / hi2); + double z = (volatile double)(hi1 / lo2); + double w = (volatile double)(hi1 / hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + double lo = fast_fmin4_double(x, y, z, w); + restore_fp_reg(oldreg); + return lo; +} + +extern double rounded_hw_interval_div_add_double_up(double lo1, double hi1, double lo2, double hi2, double hi3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + double x = (volatile double)(lo1 / lo2); + double y = (volatile double)(lo1 / hi2); + double z = (volatile double)(hi1 / lo2); + double w = (volatile double)(hi1 / hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + volatile double hi = fast_fmax4_double(x, y, z, w) + hi3; + restore_fp_reg(oldreg); + return hi; +} + +extern double rounded_hw_interval_div_add_double_down(double lo1, double hi1, double lo2, double hi2, double lo3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + double x = (volatile double)(lo1 / lo2); + double y = (volatile double)(lo1 / hi2); + double z = (volatile double)(hi1 / lo2); + double w = (volatile double)(hi1 / hi2); + if (isnan(x)) x = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0; /* 0 / 0, +-inf / +-inf -> 0 */ + volatile double lo = fast_fmin4_double(x, y, z, w) + lo3; + restore_fp_reg(oldreg); + return lo; +} + +// +// Vector Operations +// + +extern double rounded_hw_vector_sum_double(HsInt mode, HsInt length, HsInt offset, const double *a) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + volatile double s = 0.0; + for (HsInt i = 0; i < length; ++i) { + s += a[offset + i]; + } + restore_fp_reg(oldreg); + return s; +} + +extern void rounded_hw_vector_add_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] + b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_sub_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] - b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_mul_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] * b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_fma_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b, HsInt offsetC, const double * restrict c) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = fma(a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_div_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a, HsInt offsetB, const double * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] / b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_sqrt_double(HsInt mode, HsInt length, HsInt offsetR, double * restrict result, HsInt offsetA, const double * restrict a) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = sqrt(a[offsetA + i]); + } + restore_fp_reg(oldreg); +} + +// +// float +// + +static inline float rounded_add_impl_float(native_rounding_mode mode, float a, float b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float c = a + b; + restore_fp_reg(oldreg); + return c; +} +extern float rounded_hw_add_float(HsInt mode, float a, float b) +{ return rounded_add_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_add_float_up(float a, float b) +{ return rounded_add_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_add_float_down(float a, float b) +{ return rounded_add_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_add_float_zero(float a, float b) +{ return rounded_add_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline float rounded_sub_impl_float(native_rounding_mode mode, float a, float b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float c = a - b; + restore_fp_reg(oldreg); + return c; +} +extern float rounded_hw_sub_float(HsInt mode, float a, float b) +{ return rounded_sub_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_sub_float_up(float a, float b) +{ return rounded_sub_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_sub_float_down(float a, float b) +{ return rounded_sub_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_sub_float_zero(float a, float b) +{ return rounded_sub_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline float rounded_mul_impl_float(native_rounding_mode mode, float a, float b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float c = a * b; + restore_fp_reg(oldreg); + return c; +} +extern float rounded_hw_mul_float(HsInt mode, float a, float b) +{ return rounded_mul_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_mul_float_up(float a, float b) +{ return rounded_mul_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_mul_float_down(float a, float b) +{ return rounded_mul_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_mul_float_zero(float a, float b) +{ return rounded_mul_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline float rounded_div_impl_float(native_rounding_mode mode, float a, float b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float c = a / b; + restore_fp_reg(oldreg); + return c; +} +extern float rounded_hw_div_float(HsInt mode, float a, float b) +{ return rounded_div_impl_float(hs_rounding_mode_to_native(mode), a, b); } +extern float rounded_hw_div_float_up(float a, float b) +{ return rounded_div_impl_float(ROUND_UPWARD, a, b); } +extern float rounded_hw_div_float_down(float a, float b) +{ return rounded_div_impl_float(ROUND_DOWNWARD, a, b); } +extern float rounded_hw_div_float_zero(float a, float b) +{ return rounded_div_impl_float(ROUND_TOWARDZERO, a, b); } + +static inline float rounded_sqrt_impl_float(native_rounding_mode mode, float a) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float c = sqrtf(a); + restore_fp_reg(oldreg); + return c; +} +extern float rounded_hw_sqrt_float(HsInt mode, float a) +{ return rounded_sqrt_impl_float(hs_rounding_mode_to_native(mode), a); } +extern float rounded_hw_sqrt_float_up(float a) +{ return rounded_sqrt_impl_float(ROUND_UPWARD, a); } +extern float rounded_hw_sqrt_float_down(float a) +{ return rounded_sqrt_impl_float(ROUND_DOWNWARD, a); } +extern float rounded_hw_sqrt_float_zero(float a) +{ return rounded_sqrt_impl_float(ROUND_TOWARDZERO, a); } + +static inline float rounded_fma_impl_float(native_rounding_mode mode, float a, float b, float c) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float result = fmaf(a, b, c); + restore_fp_reg(oldreg); + return result; +} +extern float rounded_hw_fma_float(HsInt mode, float a, float b, float c) +{ return rounded_fma_impl_float(hs_rounding_mode_to_native(mode), a, b, c); } +extern float rounded_hw_fma_float_up(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_UPWARD, a, b, c); } +extern float rounded_hw_fma_float_down(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_DOWNWARD, a, b, c); } +extern float rounded_hw_fma_float_zero(float a, float b, float c) +{ return rounded_fma_impl_float(ROUND_TOWARDZERO, a, b, c); } + +static inline float rounded_fma_if_fast_impl_float(native_rounding_mode mode, float a, float b, float c) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); +#ifdef FP_FAST_FMAF + volatile float result = fmaf(a, b, c); +#else + volatile float result = a * b + c; +#endif + restore_fp_reg(oldreg); + return result; +} +extern float rounded_hw_fma_if_fast_float(HsInt mode, float a, float b, float c) +{ return rounded_fma_if_fast_impl_float(hs_rounding_mode_to_native(mode), a, b, c); } +extern float rounded_hw_fma_if_fast_float_up(float a, float b, float c) +{ return rounded_fma_if_fast_impl_float(ROUND_UPWARD, a, b, c); } +extern float rounded_hw_fma_if_fast_float_down(float a, float b, float c) +{ return rounded_fma_if_fast_impl_float(ROUND_DOWNWARD, a, b, c); } +extern float rounded_hw_fma_if_fast_float_zero(float a, float b, float c) +{ return rounded_fma_if_fast_impl_float(ROUND_TOWARDZERO, a, b, c); } + +// +// Conversion +// + +static inline float rounded_int64_to_float_impl(native_rounding_mode mode, int64_t x) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float result = (float)x; + restore_fp_reg(oldreg); + return result; +} +extern float rounded_hw_int64_to_float(HsInt mode, int64_t x) +{ return rounded_int64_to_float_impl(hs_rounding_mode_to_native(mode), x); } +extern float rounded_hw_int64_to_float_up(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_UPWARD, x); } +extern float rounded_hw_int64_to_float_down(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_DOWNWARD, x); } +extern float rounded_hw_int64_to_float_zero(int64_t x) +{ return rounded_int64_to_float_impl(ROUND_TOWARDZERO, x); } + +static inline float rounded_word64_to_float_impl(native_rounding_mode mode, uint64_t x) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, mode); + volatile float result = (float)x; + restore_fp_reg(oldreg); + return result; +} +extern float rounded_hw_word64_to_float(HsInt mode, uint64_t x) +{ return rounded_word64_to_float_impl(hs_rounding_mode_to_native(mode), x); } +extern float rounded_hw_word64_to_float_up(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_UPWARD, x); } +extern float rounded_hw_word64_to_float_down(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_DOWNWARD, x); } +extern float rounded_hw_word64_to_float_zero(uint64_t x) +{ return rounded_word64_to_float_impl(ROUND_TOWARDZERO, x); } + +// +// Interval arithmetic +// + +static inline float fast_fmax_float(float x, float y) +{ + // should compile to MAX[SP][SD] instruction on x86 + return x > y ? x : y; +} +static inline float fast_fmax4_float(float x, float y, float z, float w) +{ + return fast_fmax_float(fast_fmax_float(x, y), fast_fmax_float(z, w)); +} +static inline float fast_fmin_float(float x, float y) +{ + // should compile to MIN[SP][SD] instruction on x86 + return x < y ? x : y; +} +static inline float fast_fmin4_float(float x, float y, float z, float w) +{ + return fast_fmin_float(fast_fmin_float(x, y), fast_fmin_float(z, w)); +} + +extern float rounded_hw_interval_mul_float_up(float lo1, float hi1, float lo2, float hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + float x = (volatile float)(lo1 * lo2); + float y = (volatile float)(lo1 * hi2); + float z = (volatile float)(hi1 * lo2); + float w = (volatile float)(hi1 * hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + float hi = fast_fmax4_float(x, y, z, w); + restore_fp_reg(oldreg); + return hi; +} + +extern float rounded_hw_interval_mul_float_down(float lo1, float hi1, float lo2, float hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + float x = (volatile float)(lo1 * lo2); + float y = (volatile float)(lo1 * hi2); + float z = (volatile float)(hi1 * lo2); + float w = (volatile float)(hi1 * hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + float lo = fast_fmin4_float(x, y, z, w); + restore_fp_reg(oldreg); + return lo; +} + +extern float rounded_hw_interval_mul_add_float_up(float lo1, float hi1, float lo2, float hi2, float hi3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + float x = (volatile float)(lo1 * lo2); + float y = (volatile float)(lo1 * hi2); + float z = (volatile float)(hi1 * lo2); + float w = (volatile float)(hi1 * hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + volatile float hi = fast_fmax4_float(x, y, z, w) + hi3; + restore_fp_reg(oldreg); + return hi; +} + +extern float rounded_hw_interval_mul_add_float_down(float lo1, float hi1, float lo2, float hi2, float lo3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + float x = (volatile float)(lo1 * lo2); + float y = (volatile float)(lo1 * hi2); + float z = (volatile float)(hi1 * lo2); + float w = (volatile float)(hi1 * hi2); + if (isnan(x)) x = 0.0f; /* 0 * inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 * inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 * inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 * inf -> 0 */ + volatile float lo = fast_fmin4_float(x, y, z, w) + lo3; + restore_fp_reg(oldreg); + return lo; +} + +extern float rounded_hw_interval_div_float_up(float lo1, float hi1, float lo2, float hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + float x = (volatile float)(lo1 / lo2); + float y = (volatile float)(lo1 / hi2); + float z = (volatile float)(hi1 / lo2); + float w = (volatile float)(hi1 / hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + float hi = fast_fmax4_float(x, y, z, w); + restore_fp_reg(oldreg); + return hi; +} + +extern float rounded_hw_interval_div_float_down(float lo1, float hi1, float lo2, float hi2) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + float x = (volatile float)(lo1 / lo2); + float y = (volatile float)(lo1 / hi2); + float z = (volatile float)(hi1 / lo2); + float w = (volatile float)(hi1 / hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + float lo = fast_fmin4_float(x, y, z, w); + restore_fp_reg(oldreg); + return lo; +} + +extern float rounded_hw_interval_div_add_float_up(float lo1, float hi1, float lo2, float hi2, float hi3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_UPWARD); + float x = (volatile float)(lo1 / lo2); + float y = (volatile float)(lo1 / hi2); + float z = (volatile float)(hi1 / lo2); + float w = (volatile float)(hi1 / hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + volatile float hi = fast_fmax4_float(x, y, z, w) + hi3; + restore_fp_reg(oldreg); + return hi; +} + +extern float rounded_hw_interval_div_add_float_down(float lo1, float hi1, float lo2, float hi2, float lo3) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, ROUND_DOWNWARD); + float x = (volatile float)(lo1 / lo2); + float y = (volatile float)(lo1 / hi2); + float z = (volatile float)(hi1 / lo2); + float w = (volatile float)(hi1 / hi2); + if (isnan(x)) x = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(y)) y = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(z)) z = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + if (isnan(w)) w = 0.0f; /* 0 / 0, +-inf / +-inf -> 0 */ + volatile float lo = fast_fmin4_float(x, y, z, w) + lo3; + restore_fp_reg(oldreg); + return lo; +} + +// +// Vector Operations +// + +extern float rounded_hw_vector_sum_float(HsInt mode, HsInt length, HsInt offset, const float *a) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + volatile float s = 0.0f; + for (HsInt i = 0; i < length; ++i) { + s += a[offset + i]; + } + restore_fp_reg(oldreg); + return s; +} + +extern void rounded_hw_vector_add_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] + b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_sub_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] - b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_mul_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] * b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_fma_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b, HsInt offsetC, const float * restrict c) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = fmaf(a[offsetA + i], b[offsetB + i], c[offsetC + i]); + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_div_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a, HsInt offsetB, const float * restrict b) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = a[offsetA + i] / b[offsetB + i]; + } + restore_fp_reg(oldreg); +} + +extern void rounded_hw_vector_sqrt_float(HsInt mode, HsInt length, HsInt offsetR, float * restrict result, HsInt offsetA, const float * restrict a) +{ + native_rounding_mode nmode = hs_rounding_mode_to_native(mode); + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, nmode); + for (HsInt i = 0; i < length; ++i) { + result[offsetR + i] = sqrtf(a[offsetA + i]); + } + restore_fp_reg(oldreg); +} diff --git a/cbits/rounded-float128.c b/cbits/rounded-float128.c new file mode 100644 --- /dev/null +++ b/cbits/rounded-float128.c @@ -0,0 +1,86 @@ +#define __STDC_WANT_IEC_60559_TYPES_EXT__ +#include // sqrtf128, fmaf128 +#include +#include +#include + +#pragma STDC FENV_ACCESS ON + +#if defined(__GNUC__) +#define ALWAYS_INLINE __attribute__((always_inline)) +#else +#define ALWAYS_INLINE +#endif + +#if !defined(UNREACHABLE) +#if defined(__GNUC__) +#define UNREACHABLE() __builtin_unreachable() +#else +#define UNREACHABLE() do {} while (0) +#endif +#endif + +static inline ALWAYS_INLINE +int hs_rounding_mode_to_c99(HsInt mode) +{ + switch (mode) { + case /* TowardNearest */ 0: return FE_TONEAREST; + case /* TowardNegInf */ 1: return FE_DOWNWARD; + case /* TowardInf */ 2: return FE_UPWARD; + case /* TowardZero */ 3: return FE_TOWARDZERO; + default: UNREACHABLE(); return FE_TONEAREST; + } +} + +extern void rounded_hw_add_float128(HsInt mode, _Float128 *result, const _Float128 *a, const _Float128 *b) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = *a + *b; + fesetround(oldmode); +} + +extern void rounded_hw_sub_float128(HsInt mode, _Float128 *result, const _Float128 *a, const _Float128 *b) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = *a - *b; + fesetround(oldmode); +} + +extern void rounded_hw_mul_float128(HsInt mode, _Float128 *result, const _Float128 *a, const _Float128 *b) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = *a * *b; + fesetround(oldmode); +} + +extern void rounded_hw_div_float128(HsInt mode, _Float128 *result, const _Float128 *a, const _Float128 *b) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = *a / *b; + fesetround(oldmode); +} + +extern void rounded_hw_sqrt_float128(HsInt mode, _Float128 *result, const _Float128 *a) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = sqrtf128(*a); + fesetround(oldmode); +} + +extern void rounded_hw_fma_float128(HsInt mode, _Float128 *result, const _Float128 *a, const _Float128 *b, const _Float128 *c) +{ + int oldmode = fegetround(); + fesetround(hs_rounding_mode_to_c99(mode)); + *(volatile _Float128 *)result = fmaf128(*a, *b, *c); + fesetround(oldmode); +} + +extern const char *rounded_hw_backend_name_float128(void) +{ + return "C99"; +} diff --git a/cbits/rounded-x87longdouble.c b/cbits/rounded-x87longdouble.c new file mode 100644 --- /dev/null +++ b/cbits/rounded-x87longdouble.c @@ -0,0 +1,158 @@ +#include +#include +#include +#include +#include "HsFFI.h" + +#pragma STDC FENV_ACCESS ON + +static_assert(sizeof(long double) >= 10, "long double must be 80 bits or greater"); + +#if defined(__GNUC__) +#define ALWAYS_INLINE __attribute__((always_inline)) +#else +#define ALWAYS_INLINE +#endif + +#if defined(__GNUC__) +#define UNREACHABLE() __builtin_unreachable() +#else +#define UNREACHABLE() do {} while (0) +#endif + +#if defined(USE_C99) + +typedef int fp_reg; +typedef int native_rounding_mode; +static const native_rounding_mode ROUND_TONEAREST = FE_TONEAREST; +static const native_rounding_mode ROUND_DOWNWARD = FE_DOWNWARD; +static const native_rounding_mode ROUND_UPWARD = FE_UPWARD; +static const native_rounding_mode ROUND_TOWARDZERO = FE_TOWARDZERO; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ + switch (mode) { + case /* ToNearest */ 0: return FE_TONEAREST; + case /* TowardNegInf */ 1: return FE_DOWNWARD; + case /* TowardInf */ 2: return FE_UPWARD; + case /* TowardZero */ 3: return FE_TOWARDZERO; + default: UNREACHABLE(); return FE_TONEAREST; + } +} + +static inline ALWAYS_INLINE +fp_reg get_fp_reg(void) +{ + return fegetround(); +} +static inline ALWAYS_INLINE +void set_rounding(fp_reg reg, native_rounding_mode mode) +{ + fesetround(mode); +} +static inline ALWAYS_INLINE +void restore_fp_reg(fp_reg oldmode) +{ + fesetround(oldmode); +} + +#else + +#if !defined(__GNUC__) +#error "Unsupported compiler" +#endif + +typedef uint16_t fp_reg; +typedef uint16_t native_rounding_mode; +static const native_rounding_mode ROUND_TONEAREST = 0; +static const native_rounding_mode ROUND_DOWNWARD = 1; +static const native_rounding_mode ROUND_UPWARD = 2; +static const native_rounding_mode ROUND_TOWARDZERO = 3; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ + /* + * The order of RoundingMode in Numeric.Rounded.Hardware.Internal.Rounding is + * chosen so that the conversion here becomes trivial. + */ + return (native_rounding_mode)mode; +} + +static inline ALWAYS_INLINE +fp_reg get_fp_reg(void) +{ + uint16_t cword; + asm("fstcw %0" : "=m"(cword)); + return cword; +} +static inline ALWAYS_INLINE +void set_rounding(fp_reg oldcword, native_rounding_mode mode) +{ + uint16_t newcword = (oldcword & ~(3u << 10) & ~(3u << 8)) | (mode << 10) | (3u << 8); // precision: double extended + asm("fldcw %0" : : "m"(newcword)); +} +static inline ALWAYS_INLINE +void restore_fp_reg(fp_reg cword) +{ + asm("fldcw %0" : : "m"(cword)); +} + +#endif + +extern void rounded_hw_add_longdouble(HsInt mode, long double *result, const long double* a, const long double *b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = *a + *b; + restore_fp_reg(oldreg); +} + +extern void rounded_hw_sub_longdouble(HsInt mode, long double *result, const long double* a, const long double *b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = *a - *b; + restore_fp_reg(oldreg); +} + +extern void rounded_hw_mul_longdouble(HsInt mode, long double *result, const long double* a, const long double *b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = *a * *b; + restore_fp_reg(oldreg); +} + +extern void rounded_hw_div_longdouble(HsInt mode, long double *result, const long double* a, const long double *b) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = *a / *b; + restore_fp_reg(oldreg); +} + +extern void rounded_hw_sqrt_longdouble(HsInt mode, long double *result, const long double* a) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = sqrtl(*a); + restore_fp_reg(oldreg); +} + +extern void rounded_hw_fma_longdouble(HsInt mode, long double *result, const long double* a, const long double *b, const long double *c) +{ + fp_reg oldreg = get_fp_reg(); + set_rounding(oldreg, hs_rounding_mode_to_native(mode)); + *(volatile long double *)result = fmal(*a, *b, *c); + restore_fp_reg(oldreg); +} + +extern const char *rounded_hw_backend_name_longdouble(void) { +#if defined(USE_C99) + return "C99"; +#else + return "inline assembly"; +#endif +} diff --git a/cbits/rounded.c b/cbits/rounded.c new file mode 100644 --- /dev/null +++ b/cbits/rounded.c @@ -0,0 +1,195 @@ +#include +#include +#include "HsFFI.h" + +#pragma STDC FENV_ACCESS ON + +#if defined(__GNUC__) +#define ALWAYS_INLINE __attribute__((always_inline)) +#else +#define ALWAYS_INLINE +#endif + +#if defined(__GNUC__) +#define UNREACHABLE() __builtin_unreachable() +#else +#define UNREACHABLE() do {} while (0) +#endif + +/* By default, we use SSE2 if available. Define USE_C99 to override. */ + +#if !defined(USE_C99) && !defined(USE_SSE2) && !defined(USE_AVX512) +// Detect what processor feature is available and make a decision. + +#if defined(__AVX512F__) +// If AVX512 is available, use it. +#define USE_AVX512 +#elif defined(__SSE2__) +// If SSE2 is available, use it. +#define USE_SSE2 +#elif defined(__aarch64__) +// If we are on AArch64, use the control register. +#define USE_AARCH64_FPCR +#else +// Otherwise, use C99's fesetround. +#define USE_C99 +#endif + +#elif defined(USE_C99) && defined(USE_SSE2) +#error "Invalid configuration detected: USE_C99 and USE_SSE2 are mutually exclusive" +#elif defined(USE_C99) && defined(USE_AVX512) +#error "Invalid configuration detected: USE_C99 and USE_AVX512 are mutually exclusive" +#elif defined(USE_SSE2) && defined(USE_AVX512) +#error "Invalid configuration detected: USE_SSE2 and USE_AVX512 are mutually exclusive" +#endif + +#if defined(USE_AVX512) + +#include + +typedef enum { + /* The order is same as RoundingMode in Numeric.Rounded.Hardware.Internal.Rounding */ + ROUND_TONEAREST = 0, + ROUND_DOWNWARD, + ROUND_UPWARD, + ROUND_TOWARDZERO +} native_rounding_mode; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ return (native_rounding_mode)mode; } + +static const char backend_name[] = "AVX512"; + +#elif defined(USE_SSE2) + +#include + +typedef unsigned int fp_reg; +typedef unsigned int native_rounding_mode; +static const native_rounding_mode ROUND_TONEAREST = 0; +static const native_rounding_mode ROUND_DOWNWARD = 1; +static const native_rounding_mode ROUND_UPWARD = 2; +static const native_rounding_mode ROUND_TOWARDZERO = 3; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ + /* + * The order of RoundingMode in Numeric.Rounded.Hardware.Internal.Rounding is + * chosen so that the conversion here becomes trivial. + */ + return (native_rounding_mode)mode; +} + +static inline ALWAYS_INLINE +fp_reg get_fp_reg(void) +{ + return _mm_getcsr(); +} +static inline ALWAYS_INLINE +void set_rounding(fp_reg reg, native_rounding_mode mode) +{ + _mm_setcsr((reg & ~(3u << 13)) | (mode << 13)); +} +static inline ALWAYS_INLINE +void restore_fp_reg(fp_reg reg) +{ + _mm_setcsr(reg); +} + +static const char backend_name[] = "SSE2"; + +#elif defined(USE_AARCH64_FPCR) + +typedef unsigned int fp_reg; +typedef unsigned int native_rounding_mode; +static const native_rounding_mode ROUND_TONEAREST = 0 << 22; +static const native_rounding_mode ROUND_DOWNWARD = 2 << 22; +static const native_rounding_mode ROUND_UPWARD = 1 << 22; +static const native_rounding_mode ROUND_TOWARDZERO = 3 << 22; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ + switch (mode) { + case /* ToNearest */ 0: return ROUND_TONEAREST; + case /* TowardNegInf */ 1: return ROUND_DOWNWARD; + case /* TowardInf */ 2: return ROUND_UPWARD; + case /* TowardZero */ 3: return ROUND_TOWARDZERO; + default: UNREACHABLE(); return ROUND_TONEAREST; + } +} + +static inline ALWAYS_INLINE +fp_reg get_fp_reg(void) +{ + return __builtin_aarch64_get_fpcr(); +} +static inline ALWAYS_INLINE +void set_rounding(fp_reg reg, native_rounding_mode mode) +{ + __builtin_aarch64_set_fpcr((reg & ~(3u << 22)) | mode); +} +static inline ALWAYS_INLINE +void restore_fp_reg(fp_reg reg) +{ + __builtin_aarch64_set_fpcr(reg); +} + +static const char backend_name[] = "AArch64 FPCR"; + +#elif defined(USE_C99) + +#include + +typedef int fp_reg; +typedef int native_rounding_mode; +static const native_rounding_mode ROUND_TONEAREST = FE_TONEAREST; +static const native_rounding_mode ROUND_DOWNWARD = FE_DOWNWARD; +static const native_rounding_mode ROUND_UPWARD = FE_UPWARD; +static const native_rounding_mode ROUND_TOWARDZERO = FE_TOWARDZERO; + +static inline ALWAYS_INLINE +native_rounding_mode hs_rounding_mode_to_native(HsInt mode) +{ + switch (mode) { + case /* ToNearest */ 0: return FE_TONEAREST; + case /* TowardNegInf */ 1: return FE_DOWNWARD; + case /* TowardInf */ 2: return FE_UPWARD; + case /* TowardZero */ 3: return FE_TOWARDZERO; + default: UNREACHABLE(); return FE_TONEAREST; + } +} + +static inline ALWAYS_INLINE +fp_reg get_fp_reg(void) +{ + return fegetround(); +} +static inline ALWAYS_INLINE +void set_rounding(fp_reg reg, native_rounding_mode mode) +{ + fesetround(mode); +} +static inline ALWAYS_INLINE +void restore_fp_reg(fp_reg oldmode) +{ + fesetround(oldmode); +} + +static const char backend_name[] = "C99"; + +#else +#error Please define USE_C99 or USE_SSE2 or USE_AVX512 +#endif + +#if defined(USE_AVX512) +#include "rounded-avx512.inl" +#else +#include "rounded-common.inl" +#endif + +extern const char *rounded_hw_backend_name(void) { + return backend_name; +} diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,9 @@ +import Test.DocTest + +main :: IO () +main = doctest [ "-isrc" + , "src/Numeric/Rounded/Hardware/Internal/Rounding.hs" + , "src/Numeric/Rounded/Hardware/Internal/Conversion.hs" + , "src/Numeric/Rounded/Hardware/Internal/Show.hs" + , "src/Numeric/Rounded/Hardware/Internal/FloatUtil.hs" + ] diff --git a/rounded-hw.cabal b/rounded-hw.cabal new file mode 100644 --- /dev/null +++ b/rounded-hw.cabal @@ -0,0 +1,218 @@ +cabal-version: 1.24 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 5ac460c3766d27889d7b32a2cbe50446f113a5403dec5125affc436d900f452d + +name: rounded-hw +version: 0.1.0.0 +synopsis: Directed rounding for built-in floating types +description: Please see the README on GitHub at +category: Numeric, Math +homepage: https://github.com/minoki/rounded-hw#readme +bug-reports: https://github.com/minoki/rounded-hw/issues +author: ARATA Mizuki +maintainer: minorinoki@gmail.com +copyright: 2020 ARATA Mizuki +license: BSD3 +license-file: LICENSE +tested-with: GHC == 8.6.5, GHC == 8.8.3 +build-type: Custom +extra-source-files: + README.md + ChangeLog.md + cbits/rounded-common.inl + cbits/rounded-avx512.inl + cbits/interval-prim-x86_64-sse2.S + +source-repository head + type: git + location: https://github.com/minoki/rounded-hw + +custom-setup + setup-depends: + Cabal >=1.24 + , base >=4.7 + +flag avx512 + description: Use AVX512 EVEX encoding + manual: True + default: False + +flag c99 + description: Restrict use of platform-dependent features (e.g. SSE2) and only use C99 features + manual: True + default: False + +flag float128 + description: Support Float128 + manual: True + default: False + +flag ghc-prim + description: Use GHC's "foreign import prim" on the supported platform + manual: True + default: True + +flag pure-hs + description: Disable FFI + manual: True + default: False + +flag x87-long-double + description: Support x87 "long double" + manual: True + default: True + +library + exposed-modules: + Numeric.Rounded.Hardware + Numeric.Rounded.Hardware.Backend + Numeric.Rounded.Hardware.Backend.ViaRational + Numeric.Rounded.Hardware.Class + Numeric.Rounded.Hardware.Internal + Numeric.Rounded.Hardware.Interval + Numeric.Rounded.Hardware.Interval.Class + Numeric.Rounded.Hardware.Interval.NonEmpty + Numeric.Rounded.Hardware.Rounding + Numeric.Rounded.Hardware.Vector.Storable + Numeric.Rounded.Hardware.Vector.Unboxed + other-modules: + Numeric.Rounded.Hardware.Internal.Rounding + Numeric.Rounded.Hardware.Internal.Class + Numeric.Rounded.Hardware.Internal.Constants + Numeric.Rounded.Hardware.Internal.Conversion + Numeric.Rounded.Hardware.Internal.FloatUtil + Numeric.Rounded.Hardware.Internal.RoundedResult + Numeric.Rounded.Hardware.Internal.Show + Numeric.Rounded.Hardware.Backend.Default + Numeric.Rounded.Hardware.Interval.ElementaryFunctions + hs-source-dirs: + src + build-depends: + array + , base >=4.12 && <5 + , deepseq + , integer-logarithms + , primitive + , tagged + , vector + if !flag(pure-hs) + exposed-modules: + Numeric.Rounded.Hardware.Backend.C + other-modules: + FFIWrapper.Float + FFIWrapper.Double + cpp-options: -DUSE_FFI + c-sources: + cbits/rounded.c + if flag(c99) + cc-options: -DUSE_C99 + if flag(avx512) + cc-options: -DUSE_AVX512 -mavx512f + if !flag(pure-hs) && !flag(c99) && flag(ghc-prim) && impl(ghc) && arch(x86_64) + exposed-modules: + Numeric.Rounded.Hardware.Backend.FastFFI + cpp-options: -DUSE_GHC_PRIM + if flag(avx512) + c-sources: + cbits/interval-prim-x86_64-avx512.S + else + c-sources: + cbits/interval-prim-x86_64.S + if flag(x87-long-double) && (arch(i386) || arch(x86_64)) + other-modules: + Numeric.Rounded.Hardware.Backend.X87LongDouble + cpp-options: -DUSE_X87_LONG_DOUBLE + c-sources: + cbits/rounded-x87longdouble.c + build-depends: + long-double + if flag(float128) + other-modules: + Numeric.Rounded.Hardware.Backend.Float128 + cpp-options: -DUSE_FLOAT128 + c-sources: + cbits/rounded-float128.c + build-depends: + float128 + default-language: Haskell2010 + +test-suite rounded-hw-doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + other-modules: + Paths_rounded_hw + build-depends: + array + , base >=4.12 && <5 + , deepseq + , doctest >=0.8 + , integer-logarithms + , primitive + , vector + default-language: Haskell2010 + +test-suite rounded-hw-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ConstantsSpec + FloatUtilSpec + FromIntegerSpec + FromRationalSpec + IntervalArithmeticSpec + RoundedArithmeticSpec + ShowFloatSpec + Util + VectorSpec + Paths_rounded_hw + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , array + , base >=4.12 && <5 + , deepseq + , hspec + , integer-logarithms + , primitive + , random + , rounded-hw + , vector + if flag(x87-long-double) && (arch(i386) || (arch(x86_64) && !os(windows))) + other-modules: + X87LongDoubleSpec + cpp-options: -DTEST_X87_LONG_DOUBLE + build-depends: + long-double + if flag(float128) + other-modules: + Float128Spec + cpp-options: -DTEST_FLOAT128 + build-depends: + float128 + default-language: Haskell2010 + +benchmark rounded-hw-benchmark + type: exitcode-stdio-1.0 + main-is: Benchmark.hs + other-modules: + Conversion + IGA + Paths_rounded_hw + hs-source-dirs: + benchmark + build-depends: + array + , base >=4.12 && <5 + , deepseq + , gauge + , integer-logarithms + , primitive + , rounded-hw + , vector + default-language: Haskell2010 diff --git a/src/FFIWrapper/Double.hs b/src/FFIWrapper/Double.hs new file mode 100644 --- /dev/null +++ b/src/FFIWrapper/Double.hs @@ -0,0 +1,322 @@ +-- This file was generated by etc/gen-ffi-wrapper.sh +-- DO NOT EDIT this file directly! +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module FFIWrapper.Double + ( roundedAdd + , roundedSub + , roundedMul + , roundedDiv + , roundedSqrt + , roundedFMA + , roundedFMAIfFast + , roundedFromInt64 + , roundedFromWord64 + , intervalMul_down + , intervalMul_up + , intervalDiv_down + , intervalDiv_up + , intervalMulAdd_down + , intervalMulAdd_up + , intervalDivAdd_down + , intervalDivAdd_up + , vectorSumPtr + , vectorSumByteArray + , vectorAddPtr + , vectorAddByteArray + , vectorSubPtr + , vectorSubByteArray + , vectorMulPtr + , vectorMulByteArray + , vectorFMAPtr + , vectorFMAByteArray + , vectorDivPtr + , vectorDivByteArray + , vectorSqrtPtr + , vectorSqrtByteArray + ) where +import Data.Int (Int64) +import Data.Word (Word64) +import Foreign.Ptr (Ptr) +import GHC.Exts (ByteArray#, MutableByteArray#, RealWorld) +import Numeric.Rounded.Hardware.Internal.Rounding (RoundingMode(..)) + +foreign import ccall unsafe "rounded_hw_add_double" + c_rounded_add :: Int -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_add_double_up" + c_rounded_add_up :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_add_double_down" + c_rounded_add_down :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_add_double_zero" + c_rounded_add_zero :: Double -> Double -> Double + +roundedAdd :: RoundingMode -> Double -> Double -> Double +roundedAdd r = c_rounded_add (fromEnum r) +{-# INLINE [1] roundedAdd #-} +{-# RULES +"roundedAdd/TowardNegInf" [~1] roundedAdd TowardNegInf = c_rounded_add_down +"roundedAdd/TowardInf" [~1] roundedAdd TowardInf = c_rounded_add_up +"roundedAdd/TowardZero" [~1] roundedAdd TowardZero = c_rounded_add_zero + #-} + +foreign import ccall unsafe "rounded_hw_sub_double" + c_rounded_sub :: Int -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_sub_double_up" + c_rounded_sub_up :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_sub_double_down" + c_rounded_sub_down :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_sub_double_zero" + c_rounded_sub_zero :: Double -> Double -> Double + +roundedSub :: RoundingMode -> Double -> Double -> Double +roundedSub r = c_rounded_sub (fromEnum r) +{-# INLINE [1] roundedSub #-} +{-# RULES +"roundedSub/TowardNegInf" [~1] roundedSub TowardNegInf = c_rounded_sub_down +"roundedSub/TowardInf" [~1] roundedSub TowardInf = c_rounded_sub_up +"roundedSub/TowardZero" [~1] roundedSub TowardZero = c_rounded_sub_zero + #-} + +foreign import ccall unsafe "rounded_hw_mul_double" + c_rounded_mul :: Int -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_mul_double_up" + c_rounded_mul_up :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_mul_double_down" + c_rounded_mul_down :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_mul_double_zero" + c_rounded_mul_zero :: Double -> Double -> Double + +roundedMul :: RoundingMode -> Double -> Double -> Double +roundedMul r = c_rounded_mul (fromEnum r) +{-# INLINE [1] roundedMul #-} +{-# RULES +"roundedMul/TowardNegInf" [~1] roundedMul TowardNegInf = c_rounded_mul_down +"roundedMul/TowardInf" [~1] roundedMul TowardInf = c_rounded_mul_up +"roundedMul/TowardZero" [~1] roundedMul TowardZero = c_rounded_mul_zero + #-} + +foreign import ccall unsafe "rounded_hw_div_double" + c_rounded_div :: Int -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_div_double_up" + c_rounded_div_up :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_div_double_down" + c_rounded_div_down :: Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_div_double_zero" + c_rounded_div_zero :: Double -> Double -> Double + +roundedDiv :: RoundingMode -> Double -> Double -> Double +roundedDiv r = c_rounded_div (fromEnum r) +{-# INLINE [1] roundedDiv #-} +{-# RULES +"roundedDiv/TowardNegInf" [~1] roundedDiv TowardNegInf = c_rounded_div_down +"roundedDiv/TowardInf" [~1] roundedDiv TowardInf = c_rounded_div_up +"roundedDiv/TowardZero" [~1] roundedDiv TowardZero = c_rounded_div_zero + #-} + +foreign import ccall unsafe "rounded_hw_sqrt_double" + c_rounded_sqrt :: Int -> Double -> Double +foreign import ccall unsafe "rounded_hw_sqrt_double_up" + c_rounded_sqrt_up :: Double -> Double +foreign import ccall unsafe "rounded_hw_sqrt_double_down" + c_rounded_sqrt_down :: Double -> Double +foreign import ccall unsafe "rounded_hw_sqrt_double_zero" + c_rounded_sqrt_zero :: Double -> Double + +roundedSqrt :: RoundingMode -> Double -> Double +roundedSqrt r = c_rounded_sqrt (fromEnum r) +{-# INLINE [1] roundedSqrt #-} +{-# RULES +"roundedSqrt/TowardNegInf" [~1] roundedSqrt TowardNegInf = c_rounded_sqrt_down +"roundedSqrt/TowardInf" [~1] roundedSqrt TowardInf = c_rounded_sqrt_up +"roundedSqrt/TowardZero" [~1] roundedSqrt TowardZero = c_rounded_sqrt_zero + #-} + +foreign import ccall unsafe "rounded_hw_fma_double" + c_rounded_fma :: Int -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_double_up" + c_rounded_fma_up :: Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_double_down" + c_rounded_fma_down :: Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_double_zero" + c_rounded_fma_zero :: Double -> Double -> Double -> Double + +roundedFMA :: RoundingMode -> Double -> Double -> Double -> Double +roundedFMA r = c_rounded_fma (fromEnum r) +{-# INLINE [1] roundedFMA #-} +{-# RULES +"roundedFMA/TowardNegInf" [~1] roundedFMA TowardNegInf = c_rounded_fma_down +"roundedFMA/TowardInf" [~1] roundedFMA TowardInf = c_rounded_fma_up +"roundedFMA/TowardZero" [~1] roundedFMA TowardZero = c_rounded_fma_zero + #-} + +foreign import ccall unsafe "rounded_hw_fma_if_fast_double" + c_rounded_fma_if_fast :: Int -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_if_fast_double_up" + c_rounded_fma_if_fast_up :: Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_if_fast_double_down" + c_rounded_fma_if_fast_down :: Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_fma_if_fast_double_zero" + c_rounded_fma_if_fast_zero :: Double -> Double -> Double -> Double + +roundedFMAIfFast :: RoundingMode -> Double -> Double -> Double -> Double +roundedFMAIfFast r = c_rounded_fma_if_fast (fromEnum r) +{-# INLINE [1] roundedFMAIfFast #-} +{-# RULES +"roundedFMAIfFast/TowardNegInf" [~1] roundedFMAIfFast TowardNegInf = c_rounded_fma_if_fast_down +"roundedFMAIfFast/TowardInf" [~1] roundedFMAIfFast TowardInf = c_rounded_fma_if_fast_up +"roundedFMAIfFast/TowardZero" [~1] roundedFMAIfFast TowardZero = c_rounded_fma_if_fast_zero + #-} + +foreign import ccall unsafe "rounded_hw_int64_to_double" + c_rounded_from_int64 :: Int -> Int64 -> Double +foreign import ccall unsafe "rounded_hw_int64_to_double_up" + c_rounded_from_int64_up :: Int64 -> Double +foreign import ccall unsafe "rounded_hw_int64_to_double_down" + c_rounded_from_int64_down :: Int64 -> Double +foreign import ccall unsafe "rounded_hw_int64_to_double_zero" + c_rounded_from_int64_zero :: Int64 -> Double + +roundedFromInt64 :: RoundingMode -> Int64 -> Double +roundedFromInt64 r = c_rounded_from_int64 (fromEnum r) +{-# INLINE [1] roundedFromInt64 #-} +{-# RULES +"roundedFromInt64/TowardNegInf" [~1] roundedFromInt64 TowardNegInf = c_rounded_from_int64_down +"roundedFromInt64/TowardInf" [~1] roundedFromInt64 TowardInf = c_rounded_from_int64_up +"roundedFromInt64/TowardZero" [~1] roundedFromInt64 TowardZero = c_rounded_from_int64_zero + #-} + +foreign import ccall unsafe "rounded_hw_word64_to_double" + c_rounded_from_word64 :: Int -> Word64 -> Double +foreign import ccall unsafe "rounded_hw_word64_to_double_up" + c_rounded_from_word64_up :: Word64 -> Double +foreign import ccall unsafe "rounded_hw_word64_to_double_down" + c_rounded_from_word64_down :: Word64 -> Double +foreign import ccall unsafe "rounded_hw_word64_to_double_zero" + c_rounded_from_word64_zero :: Word64 -> Double + +roundedFromWord64 :: RoundingMode -> Word64 -> Double +roundedFromWord64 r = c_rounded_from_word64 (fromEnum r) +{-# INLINE [1] roundedFromWord64 #-} +{-# RULES +"roundedFromWord64/TowardNegInf" [~1] roundedFromWord64 TowardNegInf = c_rounded_from_word64_down +"roundedFromWord64/TowardInf" [~1] roundedFromWord64 TowardInf = c_rounded_from_word64_up +"roundedFromWord64/TowardZero" [~1] roundedFromWord64 TowardZero = c_rounded_from_word64_zero + #-} + +foreign import ccall unsafe "rounded_hw_interval_mul_double_down" + intervalMul_down :: Double -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_interval_mul_double_up" + intervalMul_up :: Double -> Double -> Double -> Double -> Double + +foreign import ccall unsafe "rounded_hw_interval_div_double_down" + intervalDiv_down :: Double -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_interval_div_double_up" + intervalDiv_up :: Double -> Double -> Double -> Double -> Double + +foreign import ccall unsafe "rounded_hw_interval_mul_add_double_down" + intervalMulAdd_down :: Double -> Double -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_interval_mul_add_double_up" + intervalMulAdd_up :: Double -> Double -> Double -> Double -> Double -> Double + +foreign import ccall unsafe "rounded_hw_interval_div_add_double_down" + intervalDivAdd_down :: Double -> Double -> Double -> Double -> Double -> Double +foreign import ccall unsafe "rounded_hw_interval_div_add_double_up" + intervalDivAdd_up :: Double -> Double -> Double -> Double -> Double -> Double + +foreign import ccall unsafe "rounded_hw_vector_sum_double" + c_vectorSumPtr :: Int -> Int -> Int -> Ptr Double -> IO Double + +vectorSumPtr :: RoundingMode -> Int -> Int -> Ptr Double -> IO Double +vectorSumPtr r = c_vectorSumPtr (fromEnum r) +{-# INLINE vectorSumPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sum_double" + c_vectorSumByteArray :: Int -> Int -> Int -> ByteArray# -> Double + +vectorSumByteArray :: RoundingMode -> Int -> Int -> ByteArray# -> Double +vectorSumByteArray r = c_vectorSumByteArray (fromEnum r) +{-# INLINE vectorSumByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_add_double" + c_vectorAddPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorAddPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorAddPtr r = c_vectorAddPtr (fromEnum r) +{-# INLINE vectorAddPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_add_double" + c_vectorAddByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorAddByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorAddByteArray r = c_vectorAddByteArray (fromEnum r) +{-# INLINE vectorAddByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_sub_double" + c_vectorSubPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorSubPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorSubPtr r = c_vectorSubPtr (fromEnum r) +{-# INLINE vectorSubPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sub_double" + c_vectorSubByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorSubByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorSubByteArray r = c_vectorSubByteArray (fromEnum r) +{-# INLINE vectorSubByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_mul_double" + c_vectorMulPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorMulPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorMulPtr r = c_vectorMulPtr (fromEnum r) +{-# INLINE vectorMulPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_mul_double" + c_vectorMulByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorMulByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorMulByteArray r = c_vectorMulByteArray (fromEnum r) +{-# INLINE vectorMulByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_fma_double" + c_vectorFMAPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorFMAPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorFMAPtr r = c_vectorFMAPtr (fromEnum r) +{-# INLINE vectorFMAPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_fma_double" + c_vectorFMAByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorFMAByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorFMAByteArray r = c_vectorFMAByteArray (fromEnum r) +{-# INLINE vectorFMAByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_div_double" + c_vectorDivPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorDivPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorDivPtr r = c_vectorDivPtr (fromEnum r) +{-# INLINE vectorDivPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_div_double" + c_vectorDivByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorDivByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorDivByteArray r = c_vectorDivByteArray (fromEnum r) +{-# INLINE vectorDivByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_sqrt_double" + c_vectorSqrtPtr :: Int -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> IO () + +vectorSqrtPtr :: RoundingMode -> Int -> Int -> Ptr Double -> Int -> Ptr Double -> IO () +vectorSqrtPtr r = c_vectorSqrtPtr (fromEnum r) +{-# INLINE vectorSqrtPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sqrt_double" + c_vectorSqrtByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> IO () + +vectorSqrtByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> IO () +vectorSqrtByteArray r = c_vectorSqrtByteArray (fromEnum r) +{-# INLINE vectorSqrtByteArray #-} diff --git a/src/FFIWrapper/Float.hs b/src/FFIWrapper/Float.hs new file mode 100644 --- /dev/null +++ b/src/FFIWrapper/Float.hs @@ -0,0 +1,322 @@ +-- This file was generated by etc/gen-ffi-wrapper.sh +-- DO NOT EDIT this file directly! +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module FFIWrapper.Float + ( roundedAdd + , roundedSub + , roundedMul + , roundedDiv + , roundedSqrt + , roundedFMA + , roundedFMAIfFast + , roundedFromInt64 + , roundedFromWord64 + , intervalMul_down + , intervalMul_up + , intervalDiv_down + , intervalDiv_up + , intervalMulAdd_down + , intervalMulAdd_up + , intervalDivAdd_down + , intervalDivAdd_up + , vectorSumPtr + , vectorSumByteArray + , vectorAddPtr + , vectorAddByteArray + , vectorSubPtr + , vectorSubByteArray + , vectorMulPtr + , vectorMulByteArray + , vectorFMAPtr + , vectorFMAByteArray + , vectorDivPtr + , vectorDivByteArray + , vectorSqrtPtr + , vectorSqrtByteArray + ) where +import Data.Int (Int64) +import Data.Word (Word64) +import Foreign.Ptr (Ptr) +import GHC.Exts (ByteArray#, MutableByteArray#, RealWorld) +import Numeric.Rounded.Hardware.Internal.Rounding (RoundingMode(..)) + +foreign import ccall unsafe "rounded_hw_add_float" + c_rounded_add :: Int -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_add_float_up" + c_rounded_add_up :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_add_float_down" + c_rounded_add_down :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_add_float_zero" + c_rounded_add_zero :: Float -> Float -> Float + +roundedAdd :: RoundingMode -> Float -> Float -> Float +roundedAdd r = c_rounded_add (fromEnum r) +{-# INLINE [1] roundedAdd #-} +{-# RULES +"roundedAdd/TowardNegInf" [~1] roundedAdd TowardNegInf = c_rounded_add_down +"roundedAdd/TowardInf" [~1] roundedAdd TowardInf = c_rounded_add_up +"roundedAdd/TowardZero" [~1] roundedAdd TowardZero = c_rounded_add_zero + #-} + +foreign import ccall unsafe "rounded_hw_sub_float" + c_rounded_sub :: Int -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_sub_float_up" + c_rounded_sub_up :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_sub_float_down" + c_rounded_sub_down :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_sub_float_zero" + c_rounded_sub_zero :: Float -> Float -> Float + +roundedSub :: RoundingMode -> Float -> Float -> Float +roundedSub r = c_rounded_sub (fromEnum r) +{-# INLINE [1] roundedSub #-} +{-# RULES +"roundedSub/TowardNegInf" [~1] roundedSub TowardNegInf = c_rounded_sub_down +"roundedSub/TowardInf" [~1] roundedSub TowardInf = c_rounded_sub_up +"roundedSub/TowardZero" [~1] roundedSub TowardZero = c_rounded_sub_zero + #-} + +foreign import ccall unsafe "rounded_hw_mul_float" + c_rounded_mul :: Int -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_mul_float_up" + c_rounded_mul_up :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_mul_float_down" + c_rounded_mul_down :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_mul_float_zero" + c_rounded_mul_zero :: Float -> Float -> Float + +roundedMul :: RoundingMode -> Float -> Float -> Float +roundedMul r = c_rounded_mul (fromEnum r) +{-# INLINE [1] roundedMul #-} +{-# RULES +"roundedMul/TowardNegInf" [~1] roundedMul TowardNegInf = c_rounded_mul_down +"roundedMul/TowardInf" [~1] roundedMul TowardInf = c_rounded_mul_up +"roundedMul/TowardZero" [~1] roundedMul TowardZero = c_rounded_mul_zero + #-} + +foreign import ccall unsafe "rounded_hw_div_float" + c_rounded_div :: Int -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_div_float_up" + c_rounded_div_up :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_div_float_down" + c_rounded_div_down :: Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_div_float_zero" + c_rounded_div_zero :: Float -> Float -> Float + +roundedDiv :: RoundingMode -> Float -> Float -> Float +roundedDiv r = c_rounded_div (fromEnum r) +{-# INLINE [1] roundedDiv #-} +{-# RULES +"roundedDiv/TowardNegInf" [~1] roundedDiv TowardNegInf = c_rounded_div_down +"roundedDiv/TowardInf" [~1] roundedDiv TowardInf = c_rounded_div_up +"roundedDiv/TowardZero" [~1] roundedDiv TowardZero = c_rounded_div_zero + #-} + +foreign import ccall unsafe "rounded_hw_sqrt_float" + c_rounded_sqrt :: Int -> Float -> Float +foreign import ccall unsafe "rounded_hw_sqrt_float_up" + c_rounded_sqrt_up :: Float -> Float +foreign import ccall unsafe "rounded_hw_sqrt_float_down" + c_rounded_sqrt_down :: Float -> Float +foreign import ccall unsafe "rounded_hw_sqrt_float_zero" + c_rounded_sqrt_zero :: Float -> Float + +roundedSqrt :: RoundingMode -> Float -> Float +roundedSqrt r = c_rounded_sqrt (fromEnum r) +{-# INLINE [1] roundedSqrt #-} +{-# RULES +"roundedSqrt/TowardNegInf" [~1] roundedSqrt TowardNegInf = c_rounded_sqrt_down +"roundedSqrt/TowardInf" [~1] roundedSqrt TowardInf = c_rounded_sqrt_up +"roundedSqrt/TowardZero" [~1] roundedSqrt TowardZero = c_rounded_sqrt_zero + #-} + +foreign import ccall unsafe "rounded_hw_fma_float" + c_rounded_fma :: Int -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_float_up" + c_rounded_fma_up :: Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_float_down" + c_rounded_fma_down :: Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_float_zero" + c_rounded_fma_zero :: Float -> Float -> Float -> Float + +roundedFMA :: RoundingMode -> Float -> Float -> Float -> Float +roundedFMA r = c_rounded_fma (fromEnum r) +{-# INLINE [1] roundedFMA #-} +{-# RULES +"roundedFMA/TowardNegInf" [~1] roundedFMA TowardNegInf = c_rounded_fma_down +"roundedFMA/TowardInf" [~1] roundedFMA TowardInf = c_rounded_fma_up +"roundedFMA/TowardZero" [~1] roundedFMA TowardZero = c_rounded_fma_zero + #-} + +foreign import ccall unsafe "rounded_hw_fma_if_fast_float" + c_rounded_fma_if_fast :: Int -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_if_fast_float_up" + c_rounded_fma_if_fast_up :: Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_if_fast_float_down" + c_rounded_fma_if_fast_down :: Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_fma_if_fast_float_zero" + c_rounded_fma_if_fast_zero :: Float -> Float -> Float -> Float + +roundedFMAIfFast :: RoundingMode -> Float -> Float -> Float -> Float +roundedFMAIfFast r = c_rounded_fma_if_fast (fromEnum r) +{-# INLINE [1] roundedFMAIfFast #-} +{-# RULES +"roundedFMAIfFast/TowardNegInf" [~1] roundedFMAIfFast TowardNegInf = c_rounded_fma_if_fast_down +"roundedFMAIfFast/TowardInf" [~1] roundedFMAIfFast TowardInf = c_rounded_fma_if_fast_up +"roundedFMAIfFast/TowardZero" [~1] roundedFMAIfFast TowardZero = c_rounded_fma_if_fast_zero + #-} + +foreign import ccall unsafe "rounded_hw_int64_to_float" + c_rounded_from_int64 :: Int -> Int64 -> Float +foreign import ccall unsafe "rounded_hw_int64_to_float_up" + c_rounded_from_int64_up :: Int64 -> Float +foreign import ccall unsafe "rounded_hw_int64_to_float_down" + c_rounded_from_int64_down :: Int64 -> Float +foreign import ccall unsafe "rounded_hw_int64_to_float_zero" + c_rounded_from_int64_zero :: Int64 -> Float + +roundedFromInt64 :: RoundingMode -> Int64 -> Float +roundedFromInt64 r = c_rounded_from_int64 (fromEnum r) +{-# INLINE [1] roundedFromInt64 #-} +{-# RULES +"roundedFromInt64/TowardNegInf" [~1] roundedFromInt64 TowardNegInf = c_rounded_from_int64_down +"roundedFromInt64/TowardInf" [~1] roundedFromInt64 TowardInf = c_rounded_from_int64_up +"roundedFromInt64/TowardZero" [~1] roundedFromInt64 TowardZero = c_rounded_from_int64_zero + #-} + +foreign import ccall unsafe "rounded_hw_word64_to_float" + c_rounded_from_word64 :: Int -> Word64 -> Float +foreign import ccall unsafe "rounded_hw_word64_to_float_up" + c_rounded_from_word64_up :: Word64 -> Float +foreign import ccall unsafe "rounded_hw_word64_to_float_down" + c_rounded_from_word64_down :: Word64 -> Float +foreign import ccall unsafe "rounded_hw_word64_to_float_zero" + c_rounded_from_word64_zero :: Word64 -> Float + +roundedFromWord64 :: RoundingMode -> Word64 -> Float +roundedFromWord64 r = c_rounded_from_word64 (fromEnum r) +{-# INLINE [1] roundedFromWord64 #-} +{-# RULES +"roundedFromWord64/TowardNegInf" [~1] roundedFromWord64 TowardNegInf = c_rounded_from_word64_down +"roundedFromWord64/TowardInf" [~1] roundedFromWord64 TowardInf = c_rounded_from_word64_up +"roundedFromWord64/TowardZero" [~1] roundedFromWord64 TowardZero = c_rounded_from_word64_zero + #-} + +foreign import ccall unsafe "rounded_hw_interval_mul_float_down" + intervalMul_down :: Float -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_interval_mul_float_up" + intervalMul_up :: Float -> Float -> Float -> Float -> Float + +foreign import ccall unsafe "rounded_hw_interval_div_float_down" + intervalDiv_down :: Float -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_interval_div_float_up" + intervalDiv_up :: Float -> Float -> Float -> Float -> Float + +foreign import ccall unsafe "rounded_hw_interval_mul_add_float_down" + intervalMulAdd_down :: Float -> Float -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_interval_mul_add_float_up" + intervalMulAdd_up :: Float -> Float -> Float -> Float -> Float -> Float + +foreign import ccall unsafe "rounded_hw_interval_div_add_float_down" + intervalDivAdd_down :: Float -> Float -> Float -> Float -> Float -> Float +foreign import ccall unsafe "rounded_hw_interval_div_add_float_up" + intervalDivAdd_up :: Float -> Float -> Float -> Float -> Float -> Float + +foreign import ccall unsafe "rounded_hw_vector_sum_float" + c_vectorSumPtr :: Int -> Int -> Int -> Ptr Float -> IO Float + +vectorSumPtr :: RoundingMode -> Int -> Int -> Ptr Float -> IO Float +vectorSumPtr r = c_vectorSumPtr (fromEnum r) +{-# INLINE vectorSumPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sum_float" + c_vectorSumByteArray :: Int -> Int -> Int -> ByteArray# -> Float + +vectorSumByteArray :: RoundingMode -> Int -> Int -> ByteArray# -> Float +vectorSumByteArray r = c_vectorSumByteArray (fromEnum r) +{-# INLINE vectorSumByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_add_float" + c_vectorAddPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorAddPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorAddPtr r = c_vectorAddPtr (fromEnum r) +{-# INLINE vectorAddPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_add_float" + c_vectorAddByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorAddByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorAddByteArray r = c_vectorAddByteArray (fromEnum r) +{-# INLINE vectorAddByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_sub_float" + c_vectorSubPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorSubPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorSubPtr r = c_vectorSubPtr (fromEnum r) +{-# INLINE vectorSubPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sub_float" + c_vectorSubByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorSubByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorSubByteArray r = c_vectorSubByteArray (fromEnum r) +{-# INLINE vectorSubByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_mul_float" + c_vectorMulPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorMulPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorMulPtr r = c_vectorMulPtr (fromEnum r) +{-# INLINE vectorMulPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_mul_float" + c_vectorMulByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorMulByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorMulByteArray r = c_vectorMulByteArray (fromEnum r) +{-# INLINE vectorMulByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_fma_float" + c_vectorFMAPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorFMAPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorFMAPtr r = c_vectorFMAPtr (fromEnum r) +{-# INLINE vectorFMAPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_fma_float" + c_vectorFMAByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorFMAByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorFMAByteArray r = c_vectorFMAByteArray (fromEnum r) +{-# INLINE vectorFMAByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_div_float" + c_vectorDivPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorDivPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorDivPtr r = c_vectorDivPtr (fromEnum r) +{-# INLINE vectorDivPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_div_float" + c_vectorDivByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () + +vectorDivByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO () +vectorDivByteArray r = c_vectorDivByteArray (fromEnum r) +{-# INLINE vectorDivByteArray #-} + +foreign import ccall unsafe "rounded_hw_vector_sqrt_float" + c_vectorSqrtPtr :: Int -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> IO () + +vectorSqrtPtr :: RoundingMode -> Int -> Int -> Ptr Float -> Int -> Ptr Float -> IO () +vectorSqrtPtr r = c_vectorSqrtPtr (fromEnum r) +{-# INLINE vectorSqrtPtr #-} + +foreign import ccall unsafe "rounded_hw_vector_sqrt_float" + c_vectorSqrtByteArray :: Int -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> IO () + +vectorSqrtByteArray :: RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> IO () +vectorSqrtByteArray r = c_vectorSqrtByteArray (fromEnum r) +{-# INLINE vectorSqrtByteArray #-} diff --git a/src/Numeric/Rounded/Hardware.hs b/src/Numeric/Rounded/Hardware.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware.hs @@ -0,0 +1,10 @@ +module Numeric.Rounded.Hardware + ( Rounded(..) + , RoundingMode(..) + , Rounding + , RoundedRing + , RoundedFractional + , RoundedSqrt + ) +where +import Numeric.Rounded.Hardware.Internal diff --git a/src/Numeric/Rounded/Hardware/Backend.hs b/src/Numeric/Rounded/Hardware/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend.hs @@ -0,0 +1,24 @@ +{-| +Module: Numeric.Rounded.Hardware.Backend + +Although popular CPUs allow program to control the rounding direction of floating-point operations, +such feature is not directly accessible to Haskell. + +Several options are available to control the rounding direction, including + + * Emulate the operations using 'Rational'. + * Emulate the desired rounding behavior using the default rounding direction (i.e. round to nearest). + * Provide the rounding-direction-controlled operations in C or assembly, and use FFI to call them from Haskell. + + * C FFI is portable, but has limitations (e.g. cannot return multiple values directly). + * GHC-specific @foreign import prim@ can return multiple values efficiently, but cannot be implemented in C. + +This library implements the first and third options, in "Numeric.Rounded.Hardware.Backend.ViaRational" and "Numeric.Rounded.Hardware.Backend.C"/"Numeric.Rounded.Hardware.Backend.FastFFI" respectively. + +The default implementation for 'Float' and 'Double' depends on the platform and package flags. +To help the programmer identify which implementation is used, this module provides a function to obtain the name of implementation. + +To disable use of FFI, enable the package flag @pure-hs@. +-} +module Numeric.Rounded.Hardware.Backend (backendName) where +import Numeric.Rounded.Hardware.Internal (backendName) diff --git a/src/Numeric/Rounded/Hardware/Backend/C.hs b/src/Numeric/Rounded/Hardware/Backend/C.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/C.hs @@ -0,0 +1,452 @@ +{-| +Module: Numeric.Rounded.Hardware.Backend.C + +The types in this module implements rounding-mode-controlled operations in C. + +There are several ways to control rounding mode in C, and an appropriate technology will be selected at compile time. +This library implements the following options: + + * C99 @fesetround@ + * On x86 systems, + + * SSE2 MXCSR (for 'Float' and 'Double') + * AVX512 EVEX encoding (for 'Float' and 'Double') + * x87 Control Word (for 'Numeric.LongDouble.LongDouble') + + * On AArch64, FPCR + +You should not need to import this module directly. + +This module is not available if the package flag @pure-hs@ is set. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Backend.C + ( CFloat(..) + , CDouble(..) + , VUM.MVector(..) + , VU.Vector(..) + ) where +import Control.DeepSeq (NFData (..)) +import Data.Bifunctor +import Data.Coerce +import Data.Int (Int64) +import Data.Primitive (Prim) +import Data.Primitive.ByteArray +import Data.Ratio +import Data.Tagged +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Primitive.Mutable as VPM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Data.Vector.Unboxed.Base as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Data.Word (Word64) +import qualified FFIWrapper.Double as D +import qualified FFIWrapper.Float as F +import Foreign.C.String (CString, peekCString) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import GHC.Exts (RealWorld) +import Numeric.Rounded.Hardware.Internal.Class +import Numeric.Rounded.Hardware.Internal.Conversion +import System.IO.Unsafe (unsafePerformIO) + +-- +-- Float +-- + +-- | A wrapper providing particular instances for 'RoundedRing', 'RoundedFractional' and 'RoundedSqrt'. +-- +-- This type is different from @CFloat@ from "Foreign.C.Types". +newtype CFloat = CFloat Float + deriving (Eq,Ord,Show,Generic,Num,Storable) + +instance NFData CFloat + +roundedFloatFromInt64 :: RoundingMode -> Int64 -> Float +roundedFloatFromInt64 r x = staticIf + (-0x1000000 <= x && x <= 0x1000000 {- abs x <= 2^24 -}) -- if input is known to be small enough + (fromIntegral x) + (F.roundedFromInt64 r x) +{-# INLINE roundedFloatFromInt64 #-} + +roundedFloatFromWord64 :: RoundingMode -> Word64 -> Float +roundedFloatFromWord64 r x = staticIf + (x <= 0x1000000 {- x <= 2^24 -}) -- if input is known to be small enough + (fromIntegral x) + (F.roundedFromWord64 r x) +{-# INLINE roundedFloatFromWord64 #-} + +roundedFloatFromInteger :: RoundingMode -> Integer -> Float +roundedFloatFromInteger r x + | -0x1000000 <= x && x <= 0x1000000 {- abs x <= 2^24 -} = fromInteger x + | otherwise = fromInt r x +{-# NOINLINE [1] roundedFloatFromInteger #-} + +{-# RULES +"roundeFloatFromInteger/Int" forall r (x :: Int). + roundedFloatFromInteger r (fromIntegral x) = roundedFloatFromInt64 r (fromIntegral x) +"roundeFloatFromInteger/Int64" forall r (x :: Int64). + roundedFloatFromInteger r (fromIntegral x) = roundedFloatFromInt64 r x +"roundeFloatFromInteger/Word" forall r (x :: Word). + roundedFloatFromInteger r (fromIntegral x) = roundedFloatFromWord64 r (fromIntegral x) +"roundeFloatFromInteger/Word64" forall r (x :: Word64). + roundedFloatFromInteger r (fromIntegral x) = roundedFloatFromWord64 r x + #-} + +intervalFloatFromInteger :: Integer -> (Rounded 'TowardNegInf Float, Rounded 'TowardInf Float) +intervalFloatFromInteger x + | -0x1000000 <= x && x <= 0x1000000 {- abs x <= 2^24 -} = (Rounded (fromInteger x), Rounded (fromInteger x)) + | otherwise = intervalFromInteger_default x + +roundedFloatFromRealFloat :: RealFloat a => RoundingMode -> a -> Float +roundedFloatFromRealFloat r x | isNaN x = 0/0 + | isInfinite x = if x > 0 then 1/0 else -1/0 + | isNegativeZero x = -0 + | otherwise = coerce (roundedFromRational r (toRational x) :: CFloat) +{-# NOINLINE [1] roundedFloatFromRealFloat #-} +{-# RULES +"roundedFloatFromRealFloat/Float" forall r (x :: Float). + roundedFloatFromRealFloat r x = x + #-} + +instance RoundedRing CFloat where + roundedAdd = coerce F.roundedAdd + roundedSub = coerce F.roundedSub + roundedMul = coerce F.roundedMul + roundedFusedMultiplyAdd = coerce F.roundedFMA + intervalMul x x' y y' = (coerce F.intervalMul_down x x' y y', coerce F.intervalMul_up x x' y y') + intervalMulAdd x x' y y' z z' = (coerce F.intervalMulAdd_down x x' y y' z, coerce F.intervalMulAdd_up x x' y y' z') + roundedFromInteger r x = CFloat (roundedFloatFromInteger r x) + intervalFromInteger = coerce intervalFloatFromInteger + backendNameT = Tagged cBackendName + {-# INLINE roundedAdd #-} + {-# INLINE roundedSub #-} + {-# INLINE roundedMul #-} + {-# INLINE roundedFusedMultiplyAdd #-} + {-# INLINE intervalMul #-} + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + +instance RoundedFractional CFloat where + roundedDiv = coerce F.roundedDiv + intervalDiv x x' y y' = (coerce F.intervalDiv_down x x' y y', coerce F.intervalDiv_up x x' y y') + intervalDivAdd x x' y y' z z' = (coerce F.intervalDivAdd_down x x' y y' z, coerce F.intervalDivAdd_up x x' y y' z') + roundedFromRational r x = CFloat $ fromRatio r (numerator x) (denominator x) + intervalFromRational = (coerce `asTypeOf` (bimap (CFloat <$>) (CFloat <$>) .)) intervalFromRational_default + roundedFromRealFloat r x = coerce (roundedFloatFromRealFloat r x) + {-# INLINE roundedDiv #-} + {-# INLINE intervalDiv #-} + {-# INLINE roundedFromRational #-} + {-# INLINE intervalFromRational #-} + {-# INLINE roundedFromRealFloat #-} + +instance RoundedSqrt CFloat where + roundedSqrt = coerce F.roundedSqrt + {-# INLINE roundedSqrt #-} + +instance RoundedRing_Vector VS.Vector CFloat where + roundedSum mode vec = CFloat $ unsafePerformIO $ + VS.unsafeWith vec $ \ptr -> F.vectorSumPtr mode (VS.length vec) 0 (castPtr ptr) + zipWith_roundedAdd = zipWith_Storable (coerce F.vectorAddPtr) + zipWith_roundedSub = zipWith_Storable (coerce F.vectorSubPtr) + zipWith_roundedMul = zipWith_Storable (coerce F.vectorMulPtr) + zipWith3_roundedFusedMultiplyAdd = zipWith3_Storable (coerce F.vectorFMAPtr) + +instance RoundedFractional_Vector VS.Vector CFloat where + zipWith_roundedDiv = zipWith_Storable (coerce F.vectorDivPtr) + +instance RoundedSqrt_Vector VS.Vector CFloat where + map_roundedSqrt = map_Storable (coerce F.vectorSqrtPtr) + +instance RoundedRing_Vector VU.Vector CFloat where + roundedSum mode (V_CFloat (VU.V_Float (VP.Vector off len (ByteArray arr)))) = + CFloat $ F.vectorSumByteArray mode len off arr + zipWith_roundedAdd = coerce (zipWith_Primitive F.vectorAddByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float) + zipWith_roundedSub = coerce (zipWith_Primitive F.vectorSubByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float) + zipWith_roundedMul = coerce (zipWith_Primitive F.vectorMulByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float) + zipWith3_roundedFusedMultiplyAdd = coerce (zipWith3_Primitive F.vectorFMAByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float) + +instance RoundedFractional_Vector VU.Vector CFloat where + zipWith_roundedDiv = coerce (zipWith_Primitive F.vectorDivByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float -> VP.Vector Float) + +instance RoundedSqrt_Vector VU.Vector CFloat where + map_roundedSqrt = coerce (map_Primitive F.vectorSqrtByteArray :: RoundingMode -> VP.Vector Float -> VP.Vector Float) + +-- +-- Double +-- + +-- | A wrapper providing particular instances for 'RoundedRing', 'RoundedFractional' and 'RoundedSqrt'. +-- +-- This type is different from @CDouble@ from "Foreign.C.Types". +newtype CDouble = CDouble Double + deriving (Eq,Ord,Show,Generic,Num,Storable) + +instance NFData CDouble + +roundedDoubleFromInt64 :: RoundingMode -> Int64 -> Double +roundedDoubleFromInt64 r x = staticIf + (-0x20000000000000 <= x && x <= 0x20000000000000 {- abs x <= 2^53 -}) -- if input is known to be small enough + (fromIntegral x) + (D.roundedFromInt64 r x) +{-# INLINE roundedDoubleFromInt64 #-} + +roundedDoubleFromWord64 :: RoundingMode -> Word64 -> Double +roundedDoubleFromWord64 r x = staticIf + (x <= 0x20000000000000 {- x <= 2^53 -}) -- if input is known to be small enough + (fromIntegral x) + (D.roundedFromWord64 r x) +{-# INLINE roundedDoubleFromWord64 #-} + +roundedDoubleFromInteger :: RoundingMode -> Integer -> Double +roundedDoubleFromInteger r x + | -0x20000000000000 <= x && x <= 0x20000000000000 {- abs x <= 2^53 -} = fromInteger x + | otherwise = fromInt r x +{-# NOINLINE [1] roundedDoubleFromInteger #-} + +{-# RULES +"roundedDoubleFromInteger/Int" forall r (x :: Int). + roundedDoubleFromInteger r (fromIntegral x) = roundedDoubleFromInt64 r (fromIntegral x) +"roundedDoubleFromInteger/Int64" forall r (x :: Int64). + roundedDoubleFromInteger r (fromIntegral x) = roundedDoubleFromInt64 r x +"roundedDoubleFromInteger/Word" forall r (x :: Word). + roundedDoubleFromInteger r (fromIntegral x) = roundedDoubleFromWord64 r (fromIntegral x) +"roundedDoubleFromInteger/Word64" forall r (x :: Word64). + roundedDoubleFromInteger r (fromIntegral x) = roundedDoubleFromWord64 r x + #-} + +intervalDoubleFromInteger :: Integer -> (Rounded 'TowardNegInf Double, Rounded 'TowardInf Double) +intervalDoubleFromInteger x + | -0x20000000000000 <= x && x <= 0x20000000000000 {- abs x <= 2^53 -} = (Rounded (fromInteger x), Rounded (fromInteger x)) + | otherwise = intervalFromInteger_default x + +roundedDoubleFromRealFloat :: RealFloat a => RoundingMode -> a -> Double +roundedDoubleFromRealFloat r x | isNaN x = 0/0 + | isInfinite x = if x > 0 then 1/0 else -1/0 + | isNegativeZero x = -0 + | otherwise = coerce (roundedFromRational r (toRational x) :: CDouble) +{-# NOINLINE [1] roundedDoubleFromRealFloat #-} +{-# RULES +"roundedDoubleFromRealFloat/Double" forall r (x :: Double). + roundedDoubleFromRealFloat r x = x +"roundedDoubleFromRealFloat/Float" forall r (x :: Float). + roundedDoubleFromRealFloat r x = realToFrac x -- should be rewritten into float2Double + #-} + +instance RoundedRing CDouble where + roundedAdd = coerce D.roundedAdd + roundedSub = coerce D.roundedSub + roundedMul = coerce D.roundedMul + roundedFusedMultiplyAdd = coerce D.roundedFMA + intervalMul x x' y y' = (coerce D.intervalMul_down x x' y y', coerce D.intervalMul_up x x' y y') + intervalMulAdd x x' y y' z z' = (coerce D.intervalMulAdd_down x x' y y' z, coerce D.intervalMulAdd_up x x' y y' z') + roundedFromInteger = coerce roundedDoubleFromInteger + intervalFromInteger = coerce intervalDoubleFromInteger + backendNameT = Tagged cBackendName + {-# INLINE roundedAdd #-} + {-# INLINE roundedSub #-} + {-# INLINE roundedMul #-} + {-# INLINE roundedFusedMultiplyAdd #-} + {-# INLINE intervalMul #-} + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + +instance RoundedFractional CDouble where + roundedDiv = coerce D.roundedDiv + intervalDiv x x' y y' = (coerce D.intervalDiv_down x x' y y', coerce D.intervalDiv_up x x' y y') + intervalDivAdd x x' y y' z z' = (coerce D.intervalDivAdd_down x x' y y' z, coerce D.intervalDivAdd_up x x' y y' z') + roundedFromRational r x = CDouble $ fromRatio r (numerator x) (denominator x) + intervalFromRational = (coerce `asTypeOf` (bimap (CDouble <$>) (CDouble <$>) .)) intervalFromRational_default + -- TODO: Specialize small case in ***FromRational? + roundedFromRealFloat r x = coerce (roundedDoubleFromRealFloat r x) + {-# INLINE roundedDiv #-} + {-# INLINE intervalDiv #-} + {-# INLINE roundedFromRational #-} + {-# INLINE intervalFromRational #-} + {-# INLINE roundedFromRealFloat #-} + +instance RoundedSqrt CDouble where + roundedSqrt = coerce D.roundedSqrt + {-# INLINE roundedSqrt #-} + +instance RoundedRing_Vector VS.Vector CDouble where + roundedSum mode vec = CDouble $ unsafePerformIO $ + VS.unsafeWith vec $ \ptr -> D.vectorSumPtr mode (VS.length vec) 0 (castPtr ptr) + zipWith_roundedAdd = zipWith_Storable (coerce D.vectorAddPtr) + zipWith_roundedSub = zipWith_Storable (coerce D.vectorSubPtr) + zipWith_roundedMul = zipWith_Storable (coerce D.vectorMulPtr) + zipWith3_roundedFusedMultiplyAdd = zipWith3_Storable (coerce D.vectorFMAPtr) + +instance RoundedFractional_Vector VS.Vector CDouble where + zipWith_roundedDiv = zipWith_Storable (coerce D.vectorDivPtr) + +instance RoundedSqrt_Vector VS.Vector CDouble where + map_roundedSqrt = map_Storable (coerce D.vectorSqrtPtr) + +instance RoundedRing_Vector VU.Vector CDouble where + roundedSum mode (V_CDouble (VU.V_Double (VP.Vector off len (ByteArray arr)))) = + CDouble $ D.vectorSumByteArray mode len off arr + zipWith_roundedAdd = coerce (zipWith_Primitive D.vectorAddByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double) + zipWith_roundedSub = coerce (zipWith_Primitive D.vectorSubByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double) + zipWith_roundedMul = coerce (zipWith_Primitive D.vectorMulByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double) + zipWith3_roundedFusedMultiplyAdd = coerce (zipWith3_Primitive D.vectorFMAByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double) + +instance RoundedFractional_Vector VU.Vector CDouble where + zipWith_roundedDiv = coerce (zipWith_Primitive D.vectorDivByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double -> VP.Vector Double) + +instance RoundedSqrt_Vector VU.Vector CDouble where + map_roundedSqrt = coerce (map_Primitive D.vectorSqrtByteArray :: RoundingMode -> VP.Vector Double -> VP.Vector Double) + +-- +-- Backend name +-- + +foreign import ccall unsafe "rounded_hw_backend_name" + c_backend_name :: CString + +cBackendName :: String +cBackendName = unsafePerformIO (peekCString c_backend_name) + +-- +-- Utility function for constant folding +-- + +staticIf :: Bool -> a -> a -> a +staticIf _ _ x = x +{-# INLINE [0] staticIf #-} + +{-# RULES +"staticIf/True" forall x y. staticIf True x y = x +"staticIf/False" forall x y. staticIf False x y = y + #-} + +-- +-- Utility functions for vector operations +-- + +map_Storable :: (Storable a, Storable b) => (RoundingMode -> Int -> Int -> Ptr b -> Int -> Ptr a -> IO ()) -> RoundingMode -> VS.Vector a -> VS.Vector b +map_Storable f mode vec = unsafePerformIO $ do + let !len = VS.length vec + result <- VSM.new len + VS.unsafeWith vec $ \ptr -> + VSM.unsafeWith result $ \resultPtr -> + f mode len 0 resultPtr 0 ptr + VS.unsafeFreeze result +{-# INLINE map_Storable #-} + +zipWith_Storable :: (Storable a, Storable b, Storable c) => (RoundingMode -> Int -> Int -> Ptr c -> Int -> Ptr a -> Int -> Ptr b -> IO ()) -> RoundingMode -> VS.Vector a -> VS.Vector b -> VS.Vector c +zipWith_Storable f mode vec vec' = unsafePerformIO $ do + let !len = min (VS.length vec) (VS.length vec') + result <- VSM.new len + VS.unsafeWith vec $ \ptr -> + VS.unsafeWith vec' $ \ptr' -> + VSM.unsafeWith result $ \resultPtr -> + f mode len 0 resultPtr 0 ptr 0 ptr' + VS.unsafeFreeze result +{-# INLINE zipWith_Storable #-} + +zipWith3_Storable :: (Storable a, Storable b, Storable c, Storable d) => (RoundingMode -> Int -> Int -> Ptr d -> Int -> Ptr a -> Int -> Ptr b -> Int -> Ptr c -> IO ()) -> RoundingMode -> VS.Vector a -> VS.Vector b -> VS.Vector c -> VS.Vector d +zipWith3_Storable f mode vec1 vec2 vec3 = unsafePerformIO $ do + let !len = min (VS.length vec1) (min (VS.length vec2) (VS.length vec3)) + result <- VSM.new len + VS.unsafeWith vec1 $ \ptr1 -> + VS.unsafeWith vec2 $ \ptr2 -> + VS.unsafeWith vec3 $ \ptr3 -> + VSM.unsafeWith result $ \resultPtr -> + f mode len 0 resultPtr 0 ptr1 0 ptr2 0 ptr3 + VS.unsafeFreeze result +{-# INLINE zipWith3_Storable #-} + +map_Primitive :: (Prim a, Prim b) => (RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> IO ()) -> RoundingMode -> VP.Vector a -> VP.Vector b +map_Primitive f mode (VP.Vector offA lenA (ByteArray arrA)) = unsafePerformIO $ do + result@(VPM.MVector offR lenR (MutableByteArray arrR)) <- VPM.unsafeNew lenA + f mode lenR offR arrR offA arrA + VP.unsafeFreeze result +{-# INLINE map_Primitive #-} + +zipWith_Primitive :: (Prim a, Prim b, Prim c) => (RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> IO ()) -> RoundingMode -> VP.Vector a -> VP.Vector b -> VP.Vector c +zipWith_Primitive f mode (VP.Vector offA lenA (ByteArray arrA)) (VP.Vector offB lenB (ByteArray arrB)) = unsafePerformIO $ do + result@(VPM.MVector offR lenR (MutableByteArray arrR)) <- VPM.unsafeNew (min lenA lenB) + f mode lenR offR arrR offA arrA offB arrB + VP.unsafeFreeze result +{-# INLINE zipWith_Primitive #-} + +zipWith3_Primitive :: (Prim a, Prim b, Prim c, Prim d) => (RoundingMode -> Int -> Int -> MutableByteArray# RealWorld -> Int -> ByteArray# -> Int -> ByteArray# -> Int -> ByteArray# -> IO ()) -> RoundingMode -> VP.Vector a -> VP.Vector b -> VP.Vector c -> VP.Vector d +zipWith3_Primitive f mode (VP.Vector offA lenA (ByteArray arrA)) (VP.Vector offB lenB (ByteArray arrB)) (VP.Vector offC lenC (ByteArray arrC))= unsafePerformIO $ do + result@(VPM.MVector offR lenR (MutableByteArray arrR)) <- VPM.unsafeNew (min lenA (min lenB lenC)) + f mode lenR offR arrR offA arrA offB arrB offC arrC + VP.unsafeFreeze result +{-# INLINE zipWith3_Primitive #-} + +-- +-- instance for Data.Vector.Unboxed.Unbox +-- + +newtype instance VUM.MVector s CFloat = MV_CFloat (VUM.MVector s Float) +newtype instance VU.Vector CFloat = V_CFloat (VU.Vector Float) + +instance VGM.MVector VUM.MVector CFloat where + basicLength (MV_CFloat mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_CFloat mv) = MV_CFloat (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_CFloat mv) (MV_CFloat mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_CFloat <$> VGM.basicUnsafeNew l + basicInitialize (MV_CFloat mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_CFloat <$> VGM.basicUnsafeReplicate i (coerce x) + basicUnsafeRead (MV_CFloat mv) i = coerce <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_CFloat mv) i x = VGM.basicUnsafeWrite mv i (coerce x) + basicClear (MV_CFloat mv) = VGM.basicClear mv + basicSet (MV_CFloat mv) x = VGM.basicSet mv (coerce x) + basicUnsafeCopy (MV_CFloat mv) (MV_CFloat mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_CFloat mv) (MV_CFloat mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_CFloat mv) n = MV_CFloat <$> VGM.basicUnsafeGrow mv n + +instance VG.Vector VU.Vector CFloat where + basicUnsafeFreeze (MV_CFloat mv) = V_CFloat <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_CFloat v) = MV_CFloat <$> VG.basicUnsafeThaw v + basicLength (V_CFloat v) = VG.basicLength v + basicUnsafeSlice i l (V_CFloat v) = V_CFloat (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_CFloat v) i = coerce <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_CFloat mv) (V_CFloat v) = VG.basicUnsafeCopy mv v + elemseq (V_CFloat v) x y = VG.elemseq v (coerce x) y + +instance VU.Unbox CFloat + +newtype instance VUM.MVector s CDouble = MV_CDouble (VUM.MVector s Double) +newtype instance VU.Vector CDouble = V_CDouble (VU.Vector Double) + +instance VGM.MVector VUM.MVector CDouble where + basicLength (MV_CDouble mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_CDouble mv) = MV_CDouble (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_CDouble mv) (MV_CDouble mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_CDouble <$> VGM.basicUnsafeNew l + basicInitialize (MV_CDouble mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_CDouble <$> VGM.basicUnsafeReplicate i (coerce x) + basicUnsafeRead (MV_CDouble mv) i = coerce <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_CDouble mv) i x = VGM.basicUnsafeWrite mv i (coerce x) + basicClear (MV_CDouble mv) = VGM.basicClear mv + basicSet (MV_CDouble mv) x = VGM.basicSet mv (coerce x) + basicUnsafeCopy (MV_CDouble mv) (MV_CDouble mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_CDouble mv) (MV_CDouble mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_CDouble mv) n = MV_CDouble <$> VGM.basicUnsafeGrow mv n + +instance VG.Vector VU.Vector CDouble where + basicUnsafeFreeze (MV_CDouble mv) = V_CDouble <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_CDouble v) = MV_CDouble <$> VG.basicUnsafeThaw v + basicLength (V_CDouble v) = VG.basicLength v + basicUnsafeSlice i l (V_CDouble v) = V_CDouble (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_CDouble v) i = coerce <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_CDouble mv) (V_CDouble v) = VG.basicUnsafeCopy mv v + elemseq (V_CDouble v) x y = VG.elemseq v (coerce x) y + +instance VU.Unbox CDouble diff --git a/src/Numeric/Rounded/Hardware/Backend/Default.hs b/src/Numeric/Rounded/Hardware/Backend/Default.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/Default.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +module Numeric.Rounded.Hardware.Backend.Default + () where +import Numeric.Rounded.Hardware.Internal.Class +import qualified Numeric.Rounded.Hardware.Backend.ViaRational as VR +#ifdef USE_FFI +import qualified Numeric.Rounded.Hardware.Backend.C as C +#ifdef USE_GHC_PRIM +import qualified Numeric.Rounded.Hardware.Backend.FastFFI as FastFFI +#endif +#ifdef USE_X87_LONG_DOUBLE +import Numeric.Rounded.Hardware.Backend.X87LongDouble () +#endif +#ifdef USE_FLOAT128 +import Numeric.Rounded.Hardware.Backend.Float128 () +#endif +#endif +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Unsafe.Coerce +import Data.Coerce + +#ifdef USE_FFI +#ifdef USE_GHC_PRIM +type FloatImpl = C.CFloat -- TODO: Provide FastFFI.CFloat +type DoubleImpl = FastFFI.CDouble +#else +type FloatImpl = C.CFloat +type DoubleImpl = C.CDouble +#endif +#else +type FloatImpl = VR.ViaRational Float +type DoubleImpl = VR.ViaRational Double +#endif + +deriving via FloatImpl instance RoundedRing Float +deriving via FloatImpl instance RoundedFractional Float +deriving via FloatImpl instance RoundedSqrt Float +deriving via FloatImpl instance RoundedRing_Vector VU.Vector Float +deriving via FloatImpl instance RoundedFractional_Vector VU.Vector Float +deriving via FloatImpl instance RoundedSqrt_Vector VU.Vector Float + +instance RoundedRing_Vector VS.Vector Float where + roundedSum mode vec = coerce (roundedSum mode (unsafeCoerce vec :: VS.Vector FloatImpl)) + zipWith_roundedAdd mode vec vec' = unsafeCoerce (zipWith_roundedAdd mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector FloatImpl) + zipWith_roundedSub mode vec vec' = unsafeCoerce (zipWith_roundedSub mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector FloatImpl) + zipWith_roundedMul mode vec vec' = unsafeCoerce (zipWith_roundedMul mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector FloatImpl) + {-# INLINE roundedSum #-} + {-# INLINE zipWith_roundedAdd #-} + {-# INLINE zipWith_roundedSub #-} + {-# INLINE zipWith_roundedMul #-} + +instance RoundedFractional_Vector VS.Vector Float where + zipWith_roundedDiv mode vec vec' = unsafeCoerce (zipWith_roundedDiv mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector FloatImpl) + {-# INLINE zipWith_roundedDiv #-} + +instance RoundedSqrt_Vector VS.Vector Float where + map_roundedSqrt mode vec = unsafeCoerce (map_roundedSqrt mode (unsafeCoerce vec) :: VS.Vector FloatImpl) + {-# INLINE map_roundedSqrt #-} + +deriving via DoubleImpl instance RoundedRing Double +deriving via DoubleImpl instance RoundedFractional Double +deriving via DoubleImpl instance RoundedSqrt Double +deriving via DoubleImpl instance RoundedRing_Vector VU.Vector Double +deriving via DoubleImpl instance RoundedFractional_Vector VU.Vector Double +deriving via DoubleImpl instance RoundedSqrt_Vector VU.Vector Double + +instance RoundedRing_Vector VS.Vector Double where + roundedSum mode vec = coerce (roundedSum mode (unsafeCoerce vec :: VS.Vector DoubleImpl)) + zipWith_roundedAdd mode vec vec' = unsafeCoerce (zipWith_roundedAdd mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector DoubleImpl) + zipWith_roundedSub mode vec vec' = unsafeCoerce (zipWith_roundedSub mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector DoubleImpl) + zipWith_roundedMul mode vec vec' = unsafeCoerce (zipWith_roundedMul mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector DoubleImpl) + {-# INLINE roundedSum #-} + {-# INLINE zipWith_roundedAdd #-} + {-# INLINE zipWith_roundedSub #-} + {-# INLINE zipWith_roundedMul #-} + +instance RoundedFractional_Vector VS.Vector Double where + zipWith_roundedDiv mode vec vec' = unsafeCoerce (zipWith_roundedDiv mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector DoubleImpl) + {-# INLINE zipWith_roundedDiv #-} + +instance RoundedSqrt_Vector VS.Vector Double where + map_roundedSqrt mode vec = unsafeCoerce (map_roundedSqrt mode (unsafeCoerce vec) :: VS.Vector DoubleImpl) + {-# INLINE map_roundedSqrt #-} + +-- orphaned rules +{-# RULES +"fromIntegral/a->Rounded ToNearest Float" + forall x. fromIntegral x = Rounded (roundedFromInteger ToNearest (fromIntegral x)) :: Rounded 'ToNearest Float +"fromIntegral/a->Rounded TowardInf Float" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardInf (fromIntegral x)) :: Rounded 'TowardInf Float +"fromIntegral/a->Rounded TowardNegInf Float" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardNegInf (fromIntegral x)) :: Rounded 'TowardNegInf Float +"fromIntegral/a->Rounded TowardZero Float" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardZero (fromIntegral x)) :: Rounded 'TowardZero Float +"fromIntegral/a->Rounded ToNearest Double" + forall x. fromIntegral x = Rounded (roundedFromInteger ToNearest (fromIntegral x)) :: Rounded 'ToNearest Double +"fromIntegral/a->Rounded TowardInf Double" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardInf (fromIntegral x)) :: Rounded 'TowardInf Double +"fromIntegral/a->Rounded TowardNegInf Double" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardNegInf (fromIntegral x)) :: Rounded 'TowardNegInf Double +"fromIntegral/a->Rounded TowardZero Double" + forall x. fromIntegral x = Rounded (roundedFromInteger TowardZero (fromIntegral x)) :: Rounded 'TowardZero Double + #-} diff --git a/src/Numeric/Rounded/Hardware/Backend/FastFFI.hs b/src/Numeric/Rounded/Hardware/Backend/FastFFI.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/FastFFI.hs @@ -0,0 +1,270 @@ +{-| +Module: Numeric.Rounded.Hardware.Backend.FastFFI + +The types in this module implements interval addition and subtraction in assembly. + +Currently, the only platform supported is x86_64. + +One of the following technology will be used to control rounding mode: + + * SSE2 MXCSR + * AVX512 EVEX encoding + +You should not need to import this module directly. + +This module may not be available depending on the platform or package flags. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +module Numeric.Rounded.Hardware.Backend.FastFFI + ( CDouble(..) + , fastIntervalAdd + , fastIntervalSub + , fastIntervalRecip + , VUM.MVector(MV_CFloat, MV_CDouble) + , VU.Vector(V_CFloat, V_CDouble) + ) where +import Control.DeepSeq (NFData (..)) +import Data.Coerce +import Data.Proxy +import Data.Tagged +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified FFIWrapper.Double as D +import Foreign.C.String (CString, peekCString) +import Foreign.Storable (Storable) +import GHC.Exts +import GHC.Generics (Generic) +import GHC.Int (Int64 (I64#)) +import GHC.Word (Word64 (W64#)) +import qualified Numeric.Rounded.Hardware.Backend.C as C +import Numeric.Rounded.Hardware.Internal.Class +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce + +#include "MachDeps.h" + +-- +-- Double +-- + +newtype CDouble = CDouble Double + deriving (Eq,Ord,Show,Generic,Num,Storable) + +instance NFData CDouble + +instance RoundedRing CDouble where + roundedAdd = coerce D.roundedAdd + roundedSub = coerce D.roundedSub + roundedMul = coerce D.roundedMul + roundedFusedMultiplyAdd = coerce D.roundedFMA + intervalAdd x x' y y' = coerce fastIntervalAdd x x' y y' + intervalSub x x' y y' = coerce fastIntervalSub x x' y y' + intervalMul x x' y y' = (coerce D.intervalMul_down x x' y y', coerce D.intervalMul_up x x' y y') + intervalMulAdd x x' y y' z z' = (coerce D.intervalMulAdd_down x x' y y' z, coerce D.intervalMulAdd_up x x' y y' z') + roundedFromInteger = coerce (roundedFromInteger :: RoundingMode -> Integer -> C.CDouble) + intervalFromInteger = coerce (intervalFromInteger :: Integer -> (Rounded 'TowardNegInf C.CDouble, Rounded 'TowardInf C.CDouble)) + backendNameT = Tagged $ let base = backendName (Proxy :: Proxy C.CDouble) + intervals = intervalBackendName + in if base == intervals + then base ++ "+FastFFI" + else base ++ "+FastFFI(" ++ intervals ++ ")" + {-# INLINE roundedAdd #-} + {-# INLINE roundedSub #-} + {-# INLINE roundedMul #-} + {-# INLINE roundedFusedMultiplyAdd #-} + {-# INLINE intervalAdd #-} + {-# INLINE intervalSub #-} + {-# INLINE intervalMul #-} + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + +instance RoundedFractional CDouble where + roundedDiv = coerce D.roundedDiv + intervalDiv x x' y y' = (coerce D.intervalDiv_down x x' y y', coerce D.intervalDiv_up x x' y y') + intervalDivAdd x x' y y' z z' = (coerce D.intervalDivAdd_down x x' y y' z, coerce D.intervalDivAdd_up x x' y y' z') + intervalRecip x x' = coerce fastIntervalRecip x x' + roundedFromRational = coerce (roundedFromRational :: RoundingMode -> Rational -> C.CDouble) + roundedFromRealFloat r x = coerce (roundedFromRealFloat r x :: C.CDouble) + intervalFromRational = coerce (intervalFromRational :: Rational -> (Rounded 'TowardNegInf C.CDouble, Rounded 'TowardInf C.CDouble)) + {-# INLINE roundedDiv #-} + {-# INLINE intervalDiv #-} + {-# INLINE intervalRecip #-} + {-# INLINE roundedFromRational #-} + {-# INLINE roundedFromRealFloat #-} + {-# INLINE intervalFromRational #-} + +instance RoundedSqrt CDouble where + roundedSqrt = coerce D.roundedSqrt + {-# INLINE roundedSqrt #-} + +instance RoundedRing_Vector VS.Vector CDouble where + roundedSum mode vec = coerce (roundedSum mode (unsafeCoerce vec :: VS.Vector C.CDouble)) + zipWith_roundedAdd mode vec vec' = unsafeCoerce (zipWith_roundedAdd mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector C.CDouble) + zipWith_roundedSub mode vec vec' = unsafeCoerce (zipWith_roundedSub mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector C.CDouble) + zipWith_roundedMul mode vec vec' = unsafeCoerce (zipWith_roundedMul mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector C.CDouble) + zipWith3_roundedFusedMultiplyAdd mode vec1 vec2 vec3 = unsafeCoerce (zipWith3_roundedFusedMultiplyAdd mode (unsafeCoerce vec1) (unsafeCoerce vec2) (unsafeCoerce vec3) :: VS.Vector C.CDouble) + {-# INLINE roundedSum #-} + {-# INLINE zipWith_roundedAdd #-} + {-# INLINE zipWith_roundedSub #-} + {-# INLINE zipWith_roundedMul #-} + {-# INLINE zipWith3_roundedFusedMultiplyAdd #-} + +instance RoundedFractional_Vector VS.Vector CDouble where + zipWith_roundedDiv mode vec vec' = unsafeCoerce (zipWith_roundedDiv mode (unsafeCoerce vec) (unsafeCoerce vec') :: VS.Vector C.CDouble) + {-# INLINE zipWith_roundedDiv #-} + +instance RoundedSqrt_Vector VS.Vector CDouble where + map_roundedSqrt mode vec = unsafeCoerce (map_roundedSqrt mode (unsafeCoerce vec) :: VS.Vector C.CDouble) + {-# INLINE map_roundedSqrt #-} + +deriving via C.CDouble instance RoundedRing_Vector VU.Vector CDouble +deriving via C.CDouble instance RoundedFractional_Vector VU.Vector CDouble +deriving via C.CDouble instance RoundedSqrt_Vector VU.Vector CDouble + +-- +-- FFI +-- + +foreign import prim "rounded_hw_interval_add" + fastIntervalAdd# :: Double# -- lower 1, %xmm1 + -> Double# -- upper 1, %xmm2 + -> Double# -- lower 2, %xmm3 + -> Double# -- upper 2, %xmm4 + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) + +foreign import prim "rounded_hw_interval_sub" + fastIntervalSub# :: Double# -- lower 1, %xmm1 + -> Double# -- upper 1, %xmm2 + -> Double# -- lower 2, %xmm3 + -> Double# -- upper 2, %xmm4 + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) + +foreign import prim "rounded_hw_interval_recip" + fastIntervalRecip# :: Double# -- lower 1, %xmm1 + -> Double# -- upper 1, %xmm2 + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) + +foreign import prim "rounded_hw_interval_sqrt" + fastIntervalSqrt# :: Double# -- lower 1, %xmm1 + -> Double# -- upper 1, %xmm2 + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) + +#if WORD_SIZE_IN_BITS >= 64 +type INT64# = Int# +type WORD64# = Word# +#else +type INT64# = Int64# +type WORD64# = Word64# +#endif + +foreign import prim "rounded_hw_interval_from_int64" + fastIntervalFromInt64# :: INT64# -- value + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) + +{- +foreign import prim "rounded_hw_interval_from_word64" + fastIntervalFromWord64# :: WORD64# -- value + -> (# Double# -- lower, %xmm1 + , Double# -- upper, %xmm2 + #) +-} + +fastIntervalAdd :: Double -> Double -> Double -> Double -> (Double, Double) +fastIntervalAdd (D# l1) (D# h1) (D# l2) (D# h2) = case fastIntervalAdd# l1 h1 l2 h2 of + (# l3, h3 #) -> (D# l3, D# h3) +{-# INLINE fastIntervalAdd #-} + +fastIntervalSub :: Double -> Double -> Double -> Double -> (Double, Double) +fastIntervalSub (D# l1) (D# h1) (D# l2) (D# h2) = case fastIntervalSub# l1 h1 l2 h2 of + (# l3, h3 #) -> (D# l3, D# h3) +{-# INLINE fastIntervalSub #-} + +fastIntervalRecip :: Double -> Double -> (Double, Double) +fastIntervalRecip (D# l1) (D# h1) = case fastIntervalRecip# l1 h1 of + (# l2, h2 #) -> (D# l2, D# h2) +{-# INLINE fastIntervalRecip #-} + +fastIntervalSqrt :: Double -> Double -> (Double, Double) +fastIntervalSqrt (D# l1) (D# h1) = case fastIntervalSqrt# l1 h1 of + (# l2, h2 #) -> (D# l2, D# h2) +{-# INLINE fastIntervalSqrt #-} + +fastIntervalFromInt64 :: Int64 -> (Double, Double) +fastIntervalFromInt64 (I64# x) = case fastIntervalFromInt64# x of + (# l, h #) -> (D# l, D# h) +{-# INLINE fastIntervalFromInt64 #-} + +{- +fastIntervalFromWord64 :: Word64 -> (Double, Double) +fastIntervalFromWord64 (W64# x) = case fastIntervalFromWord64# x of + (# l, h #) -> (D# l, D# h) +{-# INLINE fastIntervalFromWord64 #-} +-} + +-- +-- Backend name +-- + +foreign import ccall "&rounded_hw_interval_backend_name" + c_interval_backend_name :: CString + +intervalBackendName :: String +intervalBackendName = unsafePerformIO (peekCString c_interval_backend_name) + +-- +-- instance for Data.Vector.Unboxed.Unbox +-- + +newtype instance VUM.MVector s CDouble = MV_CDouble (VUM.MVector s Double) +newtype instance VU.Vector CDouble = V_CDouble (VU.Vector Double) + +instance VGM.MVector VUM.MVector CDouble where + basicLength (MV_CDouble mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_CDouble mv) = MV_CDouble (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_CDouble mv) (MV_CDouble mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_CDouble <$> VGM.basicUnsafeNew l + basicInitialize (MV_CDouble mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_CDouble <$> VGM.basicUnsafeReplicate i (coerce x) + basicUnsafeRead (MV_CDouble mv) i = coerce <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_CDouble mv) i x = VGM.basicUnsafeWrite mv i (coerce x) + basicClear (MV_CDouble mv) = VGM.basicClear mv + basicSet (MV_CDouble mv) x = VGM.basicSet mv (coerce x) + basicUnsafeCopy (MV_CDouble mv) (MV_CDouble mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_CDouble mv) (MV_CDouble mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_CDouble mv) n = MV_CDouble <$> VGM.basicUnsafeGrow mv n + +instance VG.Vector VU.Vector CDouble where + basicUnsafeFreeze (MV_CDouble mv) = V_CDouble <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_CDouble v) = MV_CDouble <$> VG.basicUnsafeThaw v + basicLength (V_CDouble v) = VG.basicLength v + basicUnsafeSlice i l (V_CDouble v) = V_CDouble (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_CDouble v) i = coerce <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_CDouble mv) (V_CDouble v) = VG.basicUnsafeCopy mv v + elemseq (V_CDouble v) x y = VG.elemseq v (coerce x) y + +instance VU.Unbox CDouble diff --git a/src/Numeric/Rounded/Hardware/Backend/Float128.hs b/src/Numeric/Rounded/Hardware/Backend/Float128.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/Float128.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE HexFloatLiterals #-} +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Numeric.Rounded.Hardware.Backend.Float128 + ( + ) where +import Data.Ratio +import Data.Tagged +import Foreign.C.String (CString, peekCString) +import Foreign.Marshal (alloca, with) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import Numeric.Float128 (Float128) +import Numeric.Rounded.Hardware.Internal.Class +import Numeric.Rounded.Hardware.Internal.Constants +import Numeric.Rounded.Hardware.Internal.Conversion +import System.IO.Unsafe + +foreign import ccall unsafe "rounded_hw_add_float128" + c_rounded_add_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> IO () +foreign import ccall unsafe "rounded_hw_sub_float128" + c_rounded_sub_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> IO () +foreign import ccall unsafe "rounded_hw_mul_float128" + c_rounded_mul_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> IO () +foreign import ccall unsafe "rounded_hw_div_float128" + c_rounded_div_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> IO () +foreign import ccall unsafe "rounded_hw_sqrt_float128" + c_rounded_sqrt_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> IO () +foreign import ccall unsafe "rounded_hw_fma_float128" + c_rounded_fma_float128 :: Int -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> Ptr Float128 -> IO () + +roundedAdd_f128 :: RoundingMode -> Float128 -> Float128 -> Float128 +roundedAdd_f128 mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_add_float128 (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedSub_f128 :: RoundingMode -> Float128 -> Float128 -> Float128 +roundedSub_f128 mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_sub_float128 (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedMul_f128 :: RoundingMode -> Float128 -> Float128 -> Float128 +roundedMul_f128 mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_mul_float128 (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedDiv_f128 :: RoundingMode -> Float128 -> Float128 -> Float128 +roundedDiv_f128 mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_div_float128 (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedSqrt_f128 :: RoundingMode -> Float128 -> Float128 +roundedSqrt_f128 mode x = unsafePerformIO $ + with x $ \xPtr -> + alloca $ \resultPtr -> do + c_rounded_sqrt_float128 (fromEnum mode) resultPtr xPtr + peek resultPtr + +roundedFMA_f128 :: RoundingMode -> Float128 -> Float128 -> Float128 -> Float128 +roundedFMA_f128 mode x y z = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + with z $ \zPtr -> + alloca $ \resultPtr -> do + c_rounded_fma_float128 (fromEnum mode) resultPtr xPtr yPtr zPtr + peek resultPtr + +instance RealFloatConstants Float128 where + positiveInfinity = 1/0 + negativeInfinity = -1/0 + -- 113 bits = (1 + 4 * 28) bits = (1 + 4 * 4 * 7) bits + maxFinite = 0x1.ffff_ffff_ffff_ffff_ffff_ffff_ffffp+16383 + minPositive = encodeFloat 1 (-16494) -- The literal 0x1p-16494 may yield 0 on float128-0.1 + -- minPositiveNormal = encodeFloat 1 (-16382) -- emin = 1 - emax = 1 - 16383 + pi_down = Rounded 0x1.921fb54442d18469898cc51701b8p+1 + pi_up = Rounded 0x1.921fb54442d18469898cc51701b9p+1 + -- 3*pi + three_pi_down = Rounded 0x1.2d97c7f3321d234f272993d1414ap+3 + three_pi_up = Rounded 0x1.2d97c7f3321d234f272993d1414bp+3 + -- 5*pi + five_pi_down = Rounded 0x1.f6a7a2955385e583ebeff65cc226p+3 + five_pi_up = Rounded 0x1.f6a7a2955385e583ebeff65cc227p+3 + -- log(2) + log2_down = Rounded 0x1.62e42fefa39ef35793c7673007e5p-1 + log2_up = Rounded 0x1.62e42fefa39ef35793c7673007e6p-1 + -- exp(1) + exp1_down = Rounded 0x1.5bf0a8b1457695355fb8ac404e7ap+1 + exp1_up = Rounded 0x1.5bf0a8b1457695355fb8ac404e7bp+1 + -- exp(1/2) + exp1_2_down = Rounded 0x1.a61298e1e069bc972dfefab6df33p+0 + exp1_2_up = Rounded 0x1.a61298e1e069bc972dfefab6df34p+0 + -- exp(-1/2) + expm1_2_down = Rounded 0x1.368b2fc6f9609fe7aceb46aa619bp-1 + expm1_2_up = Rounded 0x1.368b2fc6f9609fe7aceb46aa619cp-1 + -- sqrt(2) + sqrt2_down = Rounded 0x1.6a09e667f3bcc908b2fb1366ea95p+0 + sqrt2_up = Rounded 0x1.6a09e667f3bcc908b2fb1366ea96p+0 + -- sqrt(1/2) + sqrt1_2_down = Rounded 0x1.6a09e667f3bcc908b2fb1366ea95p-1 + sqrt1_2_up = Rounded 0x1.6a09e667f3bcc908b2fb1366ea96p-1 + -- sqrt(2)-1 + sqrt2m1_down = Rounded 0x1.a827999fcef32422cbec4d9baa55p-2 + sqrt2m1_up = Rounded 0x1.a827999fcef32422cbec4d9baa56p-2 + -- 3 - 2 * sqrt(2) + three_minus_2sqrt2_down = Rounded 0x1.5f619980c4336f74d04ec99156a8p-3 + three_minus_2sqrt2_up = Rounded 0x1.5f619980c4336f74d04ec99156a9p-3 + -- 2 - sqrt(2) + two_minus_sqrt2_down = Rounded 0x1.2bec333018866dee9a09d9322ad5p-1 + two_minus_sqrt2_up = Rounded 0x1.2bec333018866dee9a09d9322ad6p-1 + +instance RoundedRing Float128 where + roundedAdd = roundedAdd_f128 + roundedSub = roundedSub_f128 + roundedMul = roundedMul_f128 + roundedFusedMultiplyAdd = roundedFMA_f128 + roundedFromInteger = fromInt + intervalFromInteger = intervalFromInteger_default + backendNameT = Tagged cBackendName + {-# INLINE roundedAdd #-} + {-# INLINE roundedSub #-} + {-# INLINE roundedMul #-} + {-# INLINE roundedFusedMultiplyAdd #-} + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + +instance RoundedFractional Float128 where + roundedDiv = roundedDiv_f128 + roundedFromRational r x = fromRatio r (numerator x) (denominator x) + intervalFromRational = intervalFromRational_default + {-# INLINE roundedDiv #-} + {-# INLINE roundedFromRational #-} + {-# INLINE intervalFromRational #-} + +instance RoundedSqrt Float128 where + roundedSqrt = roundedSqrt_f128 + {-# INLINE roundedSqrt #-} + +-- +-- Backend name +-- + +foreign import ccall unsafe "rounded_hw_backend_name_float128" + c_backend_name :: CString + +cBackendName :: String +cBackendName = unsafePerformIO (peekCString c_backend_name) diff --git a/src/Numeric/Rounded/Hardware/Backend/ViaRational.hs b/src/Numeric/Rounded/Hardware/Backend/ViaRational.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/ViaRational.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Backend.ViaRational where +import Control.DeepSeq (NFData (..)) +import Control.Exception (assert) +import Data.Coerce +import Data.Functor.Product +import Data.Ratio +import Data.Tagged +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import Numeric.Rounded.Hardware.Internal.Class +import Numeric.Rounded.Hardware.Internal.Constants +import Numeric.Rounded.Hardware.Internal.Conversion +import Numeric.Rounded.Hardware.Internal.FloatUtil (nextDown, nextUp) + +newtype ViaRational a = ViaRational a + deriving (Eq,Ord,Show,Generic,Num,Storable) + +instance NFData a => NFData (ViaRational a) + +instance (RealFloat a, Num a, RealFloatConstants a) => RoundedRing (ViaRational a) where + roundedAdd r (ViaRational x) (ViaRational y) + | isNaN x || isNaN y || isInfinite x || isInfinite y = ViaRational (x + y) + | x == 0 && y == 0 = ViaRational $ if isNegativeZero x == isNegativeZero y + then x + else roundedZero + | otherwise = case toRational x + toRational y of + 0 -> ViaRational roundedZero + z -> roundedFromRational r z + where roundedZero = case r of + ToNearest -> 0 + TowardNegInf -> -0 + TowardInf -> 0 + TowardZero -> 0 + roundedSub r (ViaRational x) (ViaRational y) + | isNaN x || isNaN y || isInfinite x || isInfinite y = ViaRational (x - y) + | x == 0 && y == 0 = ViaRational $ if isNegativeZero x /= isNegativeZero y + then x + else roundedZero + | otherwise = case toRational x - toRational y of + 0 -> ViaRational roundedZero + z -> roundedFromRational r z + where roundedZero = case r of + ToNearest -> 0 + TowardNegInf -> -0 + TowardInf -> 0 + TowardZero -> 0 + roundedMul r (ViaRational x) (ViaRational y) + | isNaN x || isNaN y || isInfinite x || isInfinite y || isNegativeZero x || isNegativeZero y = ViaRational (x * y) + | otherwise = roundedFromRational r (toRational x * toRational y) + roundedFusedMultiplyAdd r (ViaRational x) (ViaRational y) (ViaRational z) + | isNaN x || isNaN y || isNaN z || isInfinite x || isInfinite y || isInfinite z = ViaRational (x * y + z) + | otherwise = case toRational x * toRational y + toRational z of + 0 -> if z == 0 && isNegativeZero (x * y) == isNegativeZero z + then ViaRational z + else ViaRational roundedZero + w -> roundedFromRational r w + where roundedZero = case r of + ToNearest -> 0 + TowardNegInf -> -0 + TowardInf -> 0 + TowardZero -> 0 + roundedFromInteger r x = ViaRational (fromInt r x) + intervalFromInteger x = case fromIntF x :: Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) a of + Pair a b -> (ViaRational <$> a, ViaRational <$> b) + backendNameT = Tagged "via Rational" + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + {-# SPECIALIZE instance RoundedRing (ViaRational Float) #-} + {-# SPECIALIZE instance RoundedRing (ViaRational Double) #-} + +instance (RealFloat a, Num a, RealFloatConstants a) => RoundedFractional (ViaRational a) where + roundedDiv r (ViaRational x) (ViaRational y) + | isNaN x || isNaN y || isInfinite x || isInfinite y || x == 0 || y == 0 = ViaRational (x / y) + | otherwise = roundedFromRational r (toRational x / toRational y) + roundedFromRational r x = ViaRational $ fromRatio r (numerator x) (denominator x) + roundedFromRealFloat r x | isNaN x = ViaRational (0/0) + | isInfinite x = ViaRational (if x > 0 then 1/0 else -1/0) + | isNegativeZero x = ViaRational (-0) + | otherwise = roundedFromRational r (toRational x) + intervalFromRational x = case fromRatioF (numerator x) (denominator x) :: Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) a of + Pair a b -> (ViaRational <$> a, ViaRational <$> b) + {-# INLINE roundedFromRational #-} + {-# INLINE intervalFromRational #-} + {-# SPECIALIZE instance RoundedFractional (ViaRational Float) #-} + {-# SPECIALIZE instance RoundedFractional (ViaRational Double) #-} + +instance (RealFloat a, RealFloatConstants a) => RoundedSqrt (ViaRational a) where + roundedSqrt r (ViaRational x) + | r /= ToNearest && x >= 0 = ViaRational $ + case compare ((toRational y) ^ (2 :: Int)) (toRational x) of + LT | r == TowardInf -> let z = nextUp y + in assert (toRational x < (toRational z) ^ (2 :: Int)) z + | otherwise -> y + EQ -> y + GT | r == TowardInf -> y + | otherwise -> let z = nextDown y + in assert ((toRational z) ^ (2 :: Int) < toRational x) z + | otherwise = ViaRational y + where y = sqrt x + +instance (RealFloat a, RealFloatConstants a, Storable a) => RoundedRing_Vector VS.Vector (ViaRational a) +instance (RealFloat a, RealFloatConstants a, Storable a) => RoundedFractional_Vector VS.Vector (ViaRational a) +instance (RealFloat a, RealFloatConstants a, Storable a) => RoundedSqrt_Vector VS.Vector (ViaRational a) +instance (RealFloat a, RealFloatConstants a, VU.Unbox a) => RoundedRing_Vector VU.Vector (ViaRational a) +instance (RealFloat a, RealFloatConstants a, VU.Unbox a) => RoundedFractional_Vector VU.Vector (ViaRational a) +instance (RealFloat a, RealFloatConstants a, VU.Unbox a) => RoundedSqrt_Vector VU.Vector (ViaRational a) + +-- +-- instance for Data.Vector.Unboxed.Unbox +-- + +newtype instance VUM.MVector s (ViaRational a) = MV_ViaRational (VUM.MVector s a) +newtype instance VU.Vector (ViaRational a) = V_ViaRational (VU.Vector a) + +instance VU.Unbox a => VGM.MVector VUM.MVector (ViaRational a) where + basicLength (MV_ViaRational mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_ViaRational mv) = MV_ViaRational (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_ViaRational mv) (MV_ViaRational mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_ViaRational <$> VGM.basicUnsafeNew l + basicInitialize (MV_ViaRational mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_ViaRational <$> VGM.basicUnsafeReplicate i (coerce x) + basicUnsafeRead (MV_ViaRational mv) i = coerce <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_ViaRational mv) i x = VGM.basicUnsafeWrite mv i (coerce x) + basicClear (MV_ViaRational mv) = VGM.basicClear mv + basicSet (MV_ViaRational mv) x = VGM.basicSet mv (coerce x) + basicUnsafeCopy (MV_ViaRational mv) (MV_ViaRational mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_ViaRational mv) (MV_ViaRational mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_ViaRational mv) n = MV_ViaRational <$> VGM.basicUnsafeGrow mv n + +instance VU.Unbox a => VG.Vector VU.Vector (ViaRational a) where + basicUnsafeFreeze (MV_ViaRational mv) = V_ViaRational <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_ViaRational v) = MV_ViaRational <$> VG.basicUnsafeThaw v + basicLength (V_ViaRational v) = VG.basicLength v + basicUnsafeSlice i l (V_ViaRational v) = V_ViaRational (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_ViaRational v) i = coerce <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_ViaRational mv) (V_ViaRational v) = VG.basicUnsafeCopy mv v + elemseq (V_ViaRational v) x y = VG.elemseq v (coerce x) y + +instance VU.Unbox a => VU.Unbox (ViaRational a) diff --git a/src/Numeric/Rounded/Hardware/Backend/X87LongDouble.hs b/src/Numeric/Rounded/Hardware/Backend/X87LongDouble.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Backend/X87LongDouble.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE HexFloatLiterals #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Numeric.Rounded.Hardware.Backend.X87LongDouble + ( + ) where +import Data.Ratio +import Data.Tagged +import Foreign.C.String (CString, peekCString) +import Foreign.Marshal (alloca, with) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import Numeric.LongDouble (LongDouble) +import Numeric.Rounded.Hardware.Internal.Class +import Numeric.Rounded.Hardware.Internal.Constants +import Numeric.Rounded.Hardware.Internal.Conversion +import System.IO.Unsafe + +foreign import ccall unsafe "rounded_hw_add_longdouble" + c_rounded_add_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> IO () +foreign import ccall unsafe "rounded_hw_sub_longdouble" + c_rounded_sub_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> IO () +foreign import ccall unsafe "rounded_hw_mul_longdouble" + c_rounded_mul_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> IO () +foreign import ccall unsafe "rounded_hw_div_longdouble" + c_rounded_div_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> IO () +foreign import ccall unsafe "rounded_hw_sqrt_longdouble" + c_rounded_sqrt_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> IO () +foreign import ccall unsafe "rounded_hw_fma_longdouble" + c_rounded_fma_longdouble :: Int -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> Ptr LongDouble -> IO () + +roundedAdd_ld :: RoundingMode -> LongDouble -> LongDouble -> LongDouble +roundedAdd_ld mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_add_longdouble (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedSub_ld :: RoundingMode -> LongDouble -> LongDouble -> LongDouble +roundedSub_ld mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_sub_longdouble (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedMul_ld :: RoundingMode -> LongDouble -> LongDouble -> LongDouble +roundedMul_ld mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_mul_longdouble (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedDiv_ld :: RoundingMode -> LongDouble -> LongDouble -> LongDouble +roundedDiv_ld mode x y = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + alloca $ \resultPtr -> do + c_rounded_div_longdouble (fromEnum mode) resultPtr xPtr yPtr + peek resultPtr + +roundedSqrt_ld :: RoundingMode -> LongDouble -> LongDouble +roundedSqrt_ld mode x = unsafePerformIO $ + with x $ \xPtr -> + alloca $ \resultPtr -> do + c_rounded_sqrt_longdouble (fromEnum mode) resultPtr xPtr + peek resultPtr + +roundedFMA_ld :: RoundingMode -> LongDouble -> LongDouble -> LongDouble -> LongDouble +roundedFMA_ld mode x y z = unsafePerformIO $ + with x $ \xPtr -> + with y $ \yPtr -> + with z $ \zPtr -> + alloca $ \resultPtr -> do + c_rounded_fma_longdouble (fromEnum mode) resultPtr xPtr yPtr zPtr + peek resultPtr + +instance RealFloatConstants LongDouble where + positiveInfinity = 1/0 + negativeInfinity = -1/0 + maxFinite = 0x1.fffffffffffffffep+16383 + minPositive = encodeFloat 1 (-16445) -- The literal 0x1p-16445 yields 0 on long-double-0.1.1 + pi_down = Rounded 0x1.921fb54442d18468p+1 + pi_up = Rounded 0x1.921fb54442d1846ap+1 + -- 3*pi + three_pi_down = Rounded 0x1.2d97c7f3321d234ep+3 + three_pi_up = Rounded 0x1.2d97c7f3321d2350p+3 + -- 5*pi + five_pi_down = Rounded 0x1.f6a7a2955385e582p+3 + five_pi_up = Rounded 0x1.f6a7a2955385e584p+3 + -- log(2) + log2_down = Rounded 0x1.62e42fefa39ef356p-1 + log2_up = Rounded 0x1.62e42fefa39ef358p-1 + -- exp(1) + exp1_down = Rounded 0x1.5bf0a8b145769534p+1 + exp1_up = Rounded 0x1.5bf0a8b145769536p+1 + -- exp(1/2) + exp1_2_down = Rounded 0x1.a61298e1e069bc96p+0 + exp1_2_up = Rounded 0x1.a61298e1e069bc98p+0 + -- exp(-1/2) + expm1_2_down = Rounded 0x1.368b2fc6f9609fe6p-1 + expm1_2_up = Rounded 0x1.368b2fc6f9609fe8p-1 + -- sqrt(2) + sqrt2_down = Rounded 0x1.6a09e667f3bcc908p+0 + sqrt2_up = Rounded 0x1.6a09e667f3bcc90ap+0 + -- sqrt(1/2) + sqrt1_2_down = Rounded 0x1.6a09e667f3bcc908p-1 + sqrt1_2_up = Rounded 0x1.6a09e667f3bcc90ap-1 + -- sqrt(2)-1 + sqrt2m1_down = Rounded 0x1.a827999fcef32422p-2 + sqrt2m1_up = Rounded 0x1.a827999fcef32424p-2 + -- 3 - 2 * sqrt(2) + three_minus_2sqrt2_down = Rounded 0x1.5f619980c4336f74p-3 + three_minus_2sqrt2_up = Rounded 0x1.5f619980c4336f76p-3 + -- 2 - sqrt(2) + two_minus_sqrt2_down = Rounded 0x1.2bec333018866deep-1 + two_minus_sqrt2_up = Rounded 0x1.2bec333018866df0p-1 + +-- | Only available on x86/x86_64 systems. +-- Note that 'LongDouble' may not work correctly on Win64. +instance RoundedRing LongDouble where + roundedAdd = roundedAdd_ld + roundedSub = roundedSub_ld + roundedMul = roundedMul_ld + roundedFusedMultiplyAdd = roundedFMA_ld + roundedFromInteger = fromInt + intervalFromInteger = intervalFromInteger_default + backendNameT = Tagged cBackendName + {-# INLINE roundedAdd #-} + {-# INLINE roundedSub #-} + {-# INLINE roundedMul #-} + {-# INLINE roundedFusedMultiplyAdd #-} + {-# INLINE roundedFromInteger #-} + {-# INLINE intervalFromInteger #-} + +-- | Only available on x86/x86_64 systems. +-- Note that 'LongDouble' may not work correctly on Win64. +instance RoundedFractional LongDouble where + roundedDiv = roundedDiv_ld + roundedFromRational r x = fromRatio r (numerator x) (denominator x) + intervalFromRational = intervalFromRational_default + {-# INLINE roundedDiv #-} + {-# INLINE roundedFromRational #-} + {-# INLINE intervalFromRational #-} + +-- | Only available on x86/x86_64 systems. +-- Note that 'LongDouble' may not work correctly on Win64. +instance RoundedSqrt LongDouble where + roundedSqrt = roundedSqrt_ld + {-# INLINE roundedSqrt #-} + +-- +-- Backend name +-- + +foreign import ccall unsafe "rounded_hw_backend_name_longdouble" + c_backend_name :: CString + +cBackendName :: String +cBackendName = unsafePerformIO (peekCString c_backend_name) diff --git a/src/Numeric/Rounded/Hardware/Class.hs b/src/Numeric/Rounded/Hardware/Class.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Class.hs @@ -0,0 +1,9 @@ +module Numeric.Rounded.Hardware.Class + ( RoundedRing(..) + , RoundedFractional(..) + , RoundedSqrt(..) + , RoundedRing_Vector(..) + , RoundedFractional_Vector(..) + , RoundedSqrt_Vector(..) + ) where +import Numeric.Rounded.Hardware.Internal diff --git a/src/Numeric/Rounded/Hardware/Internal.hs b/src/Numeric/Rounded/Hardware/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS -Wno-unused-imports #-} +module Numeric.Rounded.Hardware.Internal + ( module Internal + ) where +import Numeric.Rounded.Hardware.Backend.Default () +import Numeric.Rounded.Hardware.Internal.Class as Internal +import Numeric.Rounded.Hardware.Internal.Constants as Internal +import Numeric.Rounded.Hardware.Internal.Conversion as Internal +import Numeric.Rounded.Hardware.Internal.FloatUtil as Internal +import Numeric.Rounded.Hardware.Internal.RoundedResult as Internal +import Numeric.Rounded.Hardware.Internal.Rounding as Internal +import Numeric.Rounded.Hardware.Internal.Show as Internal diff --git a/src/Numeric/Rounded/Hardware/Internal/Class.hs b/src/Numeric/Rounded/Hardware/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/Class.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Numeric.Rounded.Hardware.Internal.Class + ( module Numeric.Rounded.Hardware.Internal.Class + , module Numeric.Rounded.Hardware.Internal.Rounding + ) where +import Data.Coerce +import Data.Proxy +import Data.Ratio +import Data.Tagged +import qualified Data.Vector.Generic as VG +import Numeric.Rounded.Hardware.Internal.Rounding +import Prelude hiding (fromInteger, fromRational, recip, sqrt, (*), + (+), (-), (/)) +import qualified Prelude + +-- | Rounding-controlled version of 'Num'. +class Ord a => RoundedRing a where + roundedAdd :: RoundingMode -> a -> a -> a + roundedSub :: RoundingMode -> a -> a -> a + roundedMul :: RoundingMode -> a -> a -> a + roundedFusedMultiplyAdd :: RoundingMode -> a -> a -> a -> a + roundedFromInteger :: RoundingMode -> Integer -> a + -- roundedToFloat :: RoundingMode -> a -> Float + -- roundedToDouble :: RoundingMode -> a -> Double + + -- | + -- prop> \x_lo x_hi y_lo y_hi -> intervalAdd (Rounded x_lo) (Rounded x_hi) (Rounded y_lo) (Rounded y_hi) == (Rounded (roundedAdd TowardNegInf x_lo y_lo), Rounded (roundedAdd TowardInf x_hi y_hi)) + intervalAdd :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalAdd x_lo x_hi y_lo y_hi = (x_lo + y_lo, x_hi + y_hi) + where (+) :: forall r. Rounding r => Rounded r a -> Rounded r a -> Rounded r a + Rounded x + Rounded y = Rounded (roundedAdd (rounding (Proxy :: Proxy r)) x y) + + -- | + -- prop> \x_lo x_hi y_lo y_hi -> intervalSub (Rounded x_lo) (Rounded x_hi) (Rounded y_lo) (Rounded y_hi) == (Rounded (roundedSub TowardNegInf x_lo y_hi), Rounded (roundedSub TowardInf x_hi y_lo)) + intervalSub :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalSub x_lo x_hi y_lo y_hi = (x_lo - coerce y_hi, x_hi - coerce y_lo) + where (-) :: forall r. Rounding r => Rounded r a -> Rounded r a -> Rounded r a + Rounded x - Rounded y = Rounded (roundedSub (rounding (Proxy :: Proxy r)) x y) + intervalMul :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalMul x_lo x_hi y_lo y_hi + = ( minimum [ x_lo * y_lo + , x_lo * coerce y_hi + , coerce x_hi * y_lo + , coerce x_hi * coerce y_hi + ] + , maximum [ coerce x_lo * coerce y_lo + , coerce x_lo * y_hi + , x_hi * coerce y_lo + , x_hi * y_hi + ] + ) + where (*) :: forall r. Rounding r => Rounded r a -> Rounded r a -> Rounded r a + Rounded x * Rounded y = Rounded (roundedMul (rounding (Proxy :: Proxy r)) x y) + intervalMulAdd :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalMulAdd x_lo x_hi y_lo y_hi z_lo z_hi = case intervalMul x_lo x_hi y_lo y_hi of + (xy_lo, xy_hi) -> intervalAdd xy_lo xy_hi z_lo z_hi + intervalFromInteger :: Integer -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalFromInteger x = (fromInteger x, fromInteger x) + where fromInteger :: forall r. Rounding r => Integer -> Rounded r a + fromInteger y = Rounded (roundedFromInteger (rounding (Proxy :: Proxy r)) y) + {-# INLINE intervalAdd #-} + {-# INLINE intervalSub #-} + {-# INLINE intervalMul #-} + {-# INLINE intervalFromInteger #-} + + backendNameT :: Tagged a String + +-- | Returns the name of backend as a string. +-- +-- Example: +-- +-- @ +-- >>> :m + Data.Proxy +-- >>> 'backendName' (Proxy :: Proxy Double) +-- "FastFFI+SSE2" +-- @ +backendName :: RoundedRing a => proxy a -> String +backendName = Data.Tagged.proxy backendNameT +{-# INLINE backendName #-} + +-- | Rounding-controlled version of 'Fractional'. +class RoundedRing a => RoundedFractional a where + roundedDiv :: RoundingMode -> a -> a -> a + roundedRecip :: RoundingMode -> a -> a + default roundedRecip :: Num a => RoundingMode -> a -> a + roundedRecip r = roundedDiv r 1 + roundedFromRational :: RoundingMode -> Rational -> a + roundedFromRealFloat :: RealFloat b => RoundingMode -> b -> a + default roundedFromRealFloat :: (Fractional a, RealFloat b) => RoundingMode -> b -> a + roundedFromRealFloat r x | isNaN x = 0 Prelude./ 0 + | isInfinite x = if x > 0 then 1 Prelude./ 0 else -1 Prelude./ 0 + | isNegativeZero x = -0 + | otherwise = roundedFromRational r (toRational x) + intervalDiv :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalDiv x_lo x_hi y_lo y_hi + = ( minimum [ x_lo / y_lo + , x_lo / coerce y_hi + , coerce x_hi / y_lo + , coerce x_hi / coerce y_hi + ] + , maximum [ coerce x_lo / coerce y_lo + , coerce x_lo / y_hi + , x_hi / coerce y_lo + , x_hi / y_hi + ] + ) + where (/) :: forall r. Rounding r => Rounded r a -> Rounded r a -> Rounded r a + Rounded x / Rounded y = Rounded (roundedDiv (rounding (Proxy :: Proxy r)) x y) + intervalDivAdd :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalDivAdd x_lo x_hi y_lo y_hi z_lo z_hi = case intervalDiv x_lo x_hi y_lo y_hi of + (xy_lo, xy_hi) -> intervalAdd xy_lo xy_hi z_lo z_hi + intervalRecip :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalRecip x_lo x_hi = (recip (coerce x_hi), recip (coerce x_lo)) + where recip :: forall r. Rounding r => Rounded r a -> Rounded r a + recip (Rounded x) = Rounded (roundedRecip (rounding (Proxy :: Proxy r)) x) + intervalFromRational :: Rational -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalFromRational x = (fromRational x, fromRational x) + where fromRational :: forall r. Rounding r => Rational -> Rounded r a + fromRational y = Rounded (roundedFromRational (rounding (Proxy :: Proxy r)) y) + {-# INLINE intervalDiv #-} + {-# INLINE intervalRecip #-} + {-# INLINE intervalFromRational #-} + +-- | Rounding-controlled version of 'sqrt'. +class RoundedRing a => RoundedSqrt a where + roundedSqrt :: RoundingMode -> a -> a + intervalSqrt :: Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) + intervalSqrt x y = (sqrt x, sqrt y) + where sqrt :: forall r. Rounding r => Rounded r a -> Rounded r a + sqrt (Rounded z) = Rounded (roundedSqrt (rounding (Proxy :: Proxy r)) z) + {-# INLINE intervalSqrt #-} + +-- | Lifted version of 'RoundedRing' +class RoundedRing a => RoundedRing_Vector vector a where + -- | Equivalent to @\\r -> foldl ('roundedAdd' r) 0@ + roundedSum :: RoundingMode -> vector a -> a + -- | Equivalent to @zipWith . 'roundedAdd'@ + zipWith_roundedAdd :: RoundingMode -> vector a -> vector a -> vector a + -- | Equivalent to @zipWith . 'roundedSub'@ + zipWith_roundedSub :: RoundingMode -> vector a -> vector a -> vector a + -- | Equivalent to @zipWith . 'roundedMul'@ + zipWith_roundedMul :: RoundingMode -> vector a -> vector a -> vector a + -- | Equivalent to @zipWith3 . 'roundedFusedMultiplyAdd'@ + zipWith3_roundedFusedMultiplyAdd :: RoundingMode -> vector a -> vector a -> vector a -> vector a + + default roundedSum :: (VG.Vector vector a, Num a) => RoundingMode -> vector a -> a + roundedSum mode = VG.foldl' (roundedAdd mode) 0 + + default zipWith_roundedAdd :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a -> vector a + zipWith_roundedAdd mode = VG.zipWith (roundedAdd mode) + + default zipWith_roundedSub :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a -> vector a + zipWith_roundedSub mode = VG.zipWith (roundedSub mode) + + default zipWith_roundedMul :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a -> vector a + zipWith_roundedMul mode = VG.zipWith (roundedMul mode) + + default zipWith3_roundedFusedMultiplyAdd :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a -> vector a -> vector a + zipWith3_roundedFusedMultiplyAdd mode = VG.zipWith3 (roundedFusedMultiplyAdd mode) + +-- | Lifted version of 'RoundedFractional' +class (RoundedFractional a, RoundedRing_Vector vector a) => RoundedFractional_Vector vector a where + -- | Equivalent to @zipWith . 'roundedDiv'@ + zipWith_roundedDiv :: RoundingMode -> vector a -> vector a -> vector a + -- map_roundedRecip :: RoundingMode -> vector a -> vector a + + default zipWith_roundedDiv :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a -> vector a + zipWith_roundedDiv mode = VG.zipWith (roundedDiv mode) + +-- | Lifted version of 'RoundedSqrt' +class (RoundedSqrt a, RoundedRing_Vector vector a) => RoundedSqrt_Vector vector a where + -- | Equivalent to @map . 'roundedSqrt'@ + map_roundedSqrt :: RoundingMode -> vector a -> vector a + + default map_roundedSqrt :: (VG.Vector vector a) => RoundingMode -> vector a -> vector a + map_roundedSqrt mode = VG.map (roundedSqrt mode) + +instance (Rounding r, Num a, RoundedRing a) => Num (Rounded r a) where + Rounded x + Rounded y = Rounded (roundedAdd (rounding (Proxy :: Proxy r)) x y) + Rounded x - Rounded y = Rounded (roundedSub (rounding (Proxy :: Proxy r)) x y) + Rounded x * Rounded y = Rounded (roundedMul (rounding (Proxy :: Proxy r)) x y) + negate = coerce (negate :: a -> a) + abs = coerce (abs :: a -> a) + signum = coerce (signum :: a -> a) + fromInteger x = Rounded (roundedFromInteger (rounding (Proxy :: Proxy r)) x) + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE (*) #-} + {-# INLINE negate #-} + {-# INLINE abs #-} + {-# INLINE signum #-} + {-# INLINE fromInteger #-} + +instance (Rounding r, Num a, RoundedFractional a) => Fractional (Rounded r a) where + Rounded x / Rounded y = Rounded (roundedDiv (rounding (Proxy :: Proxy r)) x y) + recip (Rounded x) = Rounded (roundedRecip (rounding (Proxy :: Proxy r)) x) + fromRational x = Rounded (roundedFromRational (rounding (Proxy :: Proxy r)) x) + {-# INLINE (/) #-} + {-# INLINE recip #-} + {-# INLINE fromRational #-} + +deriving newtype instance (Rounding r, Real a, RoundedFractional a) => Real (Rounded r a) +deriving newtype instance (Rounding r, RealFrac a, RoundedFractional a) => RealFrac (Rounded r a) +-- no instance for Floating/RealFloat currently... + +-- These instances are provided in Numeric.Rounded.Hardware.Backend.Default: +-- instance RoundedRing Float +-- instance RoundedFractional Float +-- instance RoundedSqrt Float +-- instance RoundedRing Double +-- instance RoundedFractional Double +-- instance RoundedSqrt Double + +instance RoundedRing Integer where + roundedAdd _ = (Prelude.+) + roundedSub _ = (Prelude.-) + roundedMul _ = (Prelude.*) + roundedFusedMultiplyAdd _ x y z = x Prelude.* y Prelude.+ z + roundedFromInteger _ = id + backendNameT = Tagged "Integer" + +instance RoundedFractional Integer where + roundedDiv r x y = roundedFromRational r (x % y) + roundedFromRational ToNearest = round + roundedFromRational TowardNegInf = floor + roundedFromRational TowardInf = ceiling + roundedFromRational TowardZero = truncate + roundedFromRealFloat r x | isNaN x = error "NaN" + | isInfinite x = error "Infinity" + | otherwise = roundedFromRational r (toRational x) + +-- TODO: instance RoundedSqrt Integer + +instance Integral a => RoundedRing (Ratio a) where + roundedAdd _ = (Prelude.+) + roundedSub _ = (Prelude.-) + roundedMul _ = (Prelude.*) + roundedFusedMultiplyAdd _ x y z = x Prelude.* y Prelude.+ z + roundedFromInteger _ = Prelude.fromInteger + backendNameT = Tagged "Rational" + +instance Integral a => RoundedFractional (Ratio a) where + roundedDiv _ = (Prelude./) + roundedRecip _ = Prelude.recip + roundedFromRational _ = Prelude.fromRational + roundedFromRealFloat _ x | isNaN x = error "NaN" + | isInfinite x = error "Infinity" + | otherwise = Prelude.fromRational (toRational x) + +-- There is no RoundedSqrt (Ratio a) diff --git a/src/Numeric/Rounded/Hardware/Internal/Constants.hs b/src/Numeric/Rounded/Hardware/Internal/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/Constants.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE HexFloatLiterals #-} +module Numeric.Rounded.Hardware.Internal.Constants where +import Numeric.Rounded.Hardware.Internal.Rounding + +class RealFloatConstants a where + -- | \(+\infty\) + positiveInfinity :: a + -- | \(-\infty\) + negativeInfinity :: a + maxFinite :: a + -- minPositiveNormal :: a + minPositive :: a + + -- | The correctly-rounded value of \(\pi\) + pi_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\pi\) + pi_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(3\pi\) + three_pi_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(3\pi\) + three_pi_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(5\pi\) + five_pi_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(5\pi\) + five_pi_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\log_e 2\) + log2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\log_e 2\) + log2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\exp(1)\) + exp1_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\exp(1)\) + exp1_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\exp(1/2)\) + exp1_2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\exp(1/2)\) + exp1_2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\exp(-1/2)\) + expm1_2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\exp(-1/2)\) + expm1_2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\sqrt{2}\) + sqrt2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\sqrt{2}\) + sqrt2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(\sqrt{2}-1\) + sqrt2m1_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(\sqrt{2}-1\) + sqrt2m1_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(1/\sqrt{2}\) + sqrt1_2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(1/\sqrt{2}\) + sqrt1_2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(3-2\sqrt{2}\) + three_minus_2sqrt2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(3-2\sqrt{2}\) + three_minus_2sqrt2_up :: Rounded 'TowardInf a + + -- | The correctly-rounded value of \(2-\sqrt{2}\) + two_minus_sqrt2_down :: Rounded 'TowardNegInf a + -- | The correctly-rounded value of \(2-\sqrt{2}\) + two_minus_sqrt2_up :: Rounded 'TowardInf a + +instance RealFloatConstants Double where + positiveInfinity = 1/0 + negativeInfinity = -1/0 + maxFinite = 0x1.fffffffffffffp+1023 + -- minPositiveNormal = 0x1p-1022 + minPositive = 0x1p-1074 -- subnormal + -- (pi :: Double) == 0x1.921fb54442d18p1 + pi_down = Rounded 0x1.921fb54442d18p+1 + pi_up = Rounded 0x1.921fb54442d19p+1 + -- 3*pi + three_pi_down = Rounded 0x1.2d97c7f3321d2p+3 + three_pi_up = Rounded 0x1.2d97c7f3321d3p+3 + -- 5*pi + five_pi_down = Rounded 0x1.f6a7a2955385ep+3 + five_pi_up = Rounded 0x1.f6a7a2955385fp+3 + -- log(2) + log2_down = Rounded 0x1.62e42fefa39efp-1 + log2_up = Rounded 0x1.62e42fefa39f0p-1 + -- exp(1) + exp1_down = Rounded 0x1.5bf0a8b145769p+1 + exp1_up = Rounded 0x1.5bf0a8b14576ap+1 + -- exp(1/2) + exp1_2_down = Rounded 0x1.a61298e1e069bp+0 + exp1_2_up = Rounded 0x1.a61298e1e069cp+0 + -- exp(-1/2) + expm1_2_down = Rounded 0x1.368b2fc6f9609p-1 + expm1_2_up = Rounded 0x1.368b2fc6f960ap-1 + -- sqrt(2) + sqrt2_down = Rounded 0x1.6a09e667f3bccp+0 + sqrt2_up = Rounded 0x1.6a09e667f3bcdp+0 + -- sqrt(1/2) + sqrt1_2_down = Rounded 0x1.6a09e667f3bccp-1 + sqrt1_2_up = Rounded 0x1.6a09e667f3bcdp-1 + -- sqrt(2)-1 + sqrt2m1_down = Rounded 0x1.a827999fcef32p-2 + sqrt2m1_up = Rounded 0x1.a827999fcef33p-2 + -- 3 - 2 * sqrt(2) + three_minus_2sqrt2_down = Rounded 0x1.5f619980c4336p-3 + three_minus_2sqrt2_up = Rounded 0x1.5f619980c4337p-3 + -- 2 - sqrt(2) + two_minus_sqrt2_down = Rounded 0x1.2bec333018866p-1 + two_minus_sqrt2_up = Rounded 0x1.2bec333018867p-1 + {-# INLINE positiveInfinity #-} + {-# INLINE negativeInfinity #-} + {-# INLINE maxFinite #-} + {-# INLINE minPositive #-} + +instance RealFloatConstants Float where + positiveInfinity = 1/0 + negativeInfinity = -1/0 + maxFinite = 0x1.fffffep+127 + minPositive = 0x1p-149 + pi_down = Rounded 0x1.921fb4p+1 + pi_up = Rounded 0x1.921fb6p+1 + -- 3*pi + three_pi_down = Rounded 0x1.2d97c6p+3 + three_pi_up = Rounded 0x1.2d97c8p+3 + -- 5*pi + five_pi_down = Rounded 0x1.f6a7a2p+3 + five_pi_up = Rounded 0x1.f6a7a4p+3 + -- log(2) + log2_down = Rounded 0x1.62e42ep-1 + log2_up = Rounded 0x1.62e430p-1 + -- exp(1) + exp1_down = Rounded 0x1.5bf0a8p+1 + exp1_up = Rounded 0x1.5bf0aap+1 + -- exp(1/2) + exp1_2_down = Rounded 0x1.a61298p+0 + exp1_2_up = Rounded 0x1.a6129ap+0 + -- exp(-1/2) + expm1_2_down = Rounded 0x1.368b2ep-1 + expm1_2_up = Rounded 0x1.368b30p-1 + -- sqrt(2) + sqrt2_down = Rounded 0x1.6a09e6p+0 + sqrt2_up = Rounded 0x1.6a09e8p+0 + -- sqrt(1/2) + sqrt1_2_down = Rounded 0x1.6a09e6p-1 + sqrt1_2_up = Rounded 0x1.6a09e8p-1 + -- sqrt(2)-1 + sqrt2m1_down = Rounded 0x1.a82798p-2 + sqrt2m1_up = Rounded 0x1.a8279ap-2 + -- 3 - 2 * sqrt(2) + three_minus_2sqrt2_down = Rounded 0x1.5f6198p-3 + three_minus_2sqrt2_up = Rounded 0x1.5f619ap-3 + -- 2 - sqrt(2) + two_minus_sqrt2_down = Rounded 0x1.2bec32p-1 + two_minus_sqrt2_up = Rounded 0x1.2bec34p-1 + {-# INLINE positiveInfinity #-} + {-# INLINE negativeInfinity #-} + {-# INLINE maxFinite #-} + {-# INLINE minPositive #-} diff --git a/src/Numeric/Rounded/Hardware/Internal/Conversion.hs b/src/Numeric/Rounded/Hardware/Internal/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/Conversion.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE HexFloatLiterals #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Numeric.Rounded.Hardware.Internal.Conversion + ( fromInt + , fromIntF + , intervalFromInteger_default + , fromRatio + , fromRatioF + , intervalFromRational_default + ) where +import Numeric.Rounded.Hardware.Internal.Rounding +import Numeric.Rounded.Hardware.Internal.RoundedResult +import Numeric.Rounded.Hardware.Internal.FloatUtil +import Data.Bits +import Data.Functor.Product +import Math.NumberTheory.Logarithms (integerLog2') +import Data.Ratio +import Control.Exception (assert) +-- import GHC.Integer.Logarithms.Internals (integerLog2IsPowerOf2#) +-- integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) + +intervalFromInteger_default :: RealFloat a => Integer -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) +intervalFromInteger_default x = case fromIntF x of Pair a b -> (a, b) +{-# SPECIALIZE intervalFromInteger_default :: Integer -> (Rounded 'TowardNegInf Float, Rounded 'TowardInf Float) #-} +{-# SPECIALIZE intervalFromInteger_default :: Integer -> (Rounded 'TowardNegInf Double, Rounded 'TowardInf Double) #-} + +intervalFromRational_default :: RealFloat a => Rational -> (Rounded 'TowardNegInf a, Rounded 'TowardInf a) +intervalFromRational_default x = case fromRatioF (numerator x) (denominator x) of Pair a b -> (a, b) +{-# SPECIALIZE intervalFromRational_default :: Rational -> (Rounded 'TowardNegInf Float, Rounded 'TowardInf Float) #-} +{-# SPECIALIZE intervalFromRational_default :: Rational -> (Rounded 'TowardNegInf Double, Rounded 'TowardInf Double) #-} + +fromInt :: RealFloat a => RoundingMode -> Integer -> a +fromInt r n = withRoundingMode (fromIntF n) r +{-# SPECIALIZE fromInt :: RoundingMode -> Integer -> Float #-} +{-# SPECIALIZE fromInt :: RoundingMode -> Integer -> Double #-} + +fromIntF :: forall a f. (RealFloat a, Result f) => Integer -> f a +fromIntF !_ | floatRadix (undefined :: a) /= 2 = error "radix other than 2 is not supported" +fromIntF 0 = exact 0 +fromIntF n | n < 0 = negate <$> withOppositeRoundingMode (fromPositiveIntF (- n)) + | otherwise = fromPositiveIntF n +{-# INLINE fromIntF #-} + +-- n > 0 +fromPositiveIntF :: forall a f. (RealFloat a, Result f) => Integer -> f a +fromPositiveIntF !n + = let !k = integerLog2' n -- floor (log2 n) + -- 2^k <= n < 2^(k+1) + !fDigits = floatDigits (undefined :: a) -- 53 for Double + in if k < fDigits + then exact (fromInteger n) + else let e = k - (fDigits - 1) + -- (!q, !r) = n `quotRem` (1 `unsafeShiftL` e) + q = n `unsafeShiftR` e + r = n .&. ((1 `unsafeShiftL` e) - 1) + -- 2^52 <= q < 2^53, 0 <= r < 2^(k-52) + (_expMin, !expMax) = floatRange (undefined :: a) -- (-1021, 1024) for Double + in if k >= expMax + then + -- infinity + inexact (1 / 0) -- ToNearest + (1 / 0) -- TowardInf + maxFinite_ieee -- TowardNegInf + maxFinite_ieee -- TowardZero + else + if r == 0 + then exact $ encodeFloat q e -- exact + else + -- inexact + let down = encodeFloat q e + up = encodeFloat (q + 1) e + toNearest = case compare r (1 `unsafeShiftL` (e-1)) of + LT -> down + EQ | even q -> down + | otherwise -> up + GT -> up + in inexact toNearest up down down +{-# SPECIALIZE fromPositiveIntF :: Integer -> DynamicRoundingMode Float #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> OppositeRoundingMode DynamicRoundingMode Float #-} +{-# SPECIALIZE fromPositiveIntF :: Rounding r => Integer -> Rounded r Float #-} +{-# SPECIALIZE fromPositiveIntF :: Rounding r => Integer -> OppositeRoundingMode (Rounded r) Float #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) Float #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> OppositeRoundingMode (Product (Rounded 'TowardNegInf) (Rounded 'TowardInf)) Float #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> DynamicRoundingMode Double #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> OppositeRoundingMode DynamicRoundingMode Double #-} +{-# SPECIALIZE fromPositiveIntF :: Rounding r => Integer -> Rounded r Double #-} +{-# SPECIALIZE fromPositiveIntF :: Rounding r => Integer -> OppositeRoundingMode (Rounded r) Double #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) Double #-} +{-# SPECIALIZE fromPositiveIntF :: Integer -> OppositeRoundingMode (Product (Rounded 'TowardNegInf) (Rounded 'TowardInf)) Double #-} + +fromRatio :: (RealFloat a) + => RoundingMode + -> Integer -- ^ numerator + -> Integer -- ^ denominator + -> a +fromRatio r n d = withRoundingMode (fromRatioF n d) r +{-# SPECIALIZE fromRatio :: RoundingMode -> Integer -> Integer -> Float #-} +{-# SPECIALIZE fromRatio :: RoundingMode -> Integer -> Integer -> Double #-} + +fromRatioF :: forall a f. (RealFloat a, Result f) + => Integer -- ^ numerator + -> Integer -- ^ denominator + -> f a +fromRatioF !_ !_ | floatRadix (undefined :: a) /= 2 = error "radix other than 2 is not supported" +fromRatioF 0 _ = exact 0 +fromRatioF n 0 | n > 0 = exact (1 / 0) -- positive infinity + | otherwise = exact (- 1 / 0) -- negative infinity +fromRatioF n d | d < 0 = error "fromRatio: negative denominator" + | n < 0 = negate <$> withOppositeRoundingMode (fromPositiveRatioF (- n) d) + | otherwise = fromPositiveRatioF n d +{-# INLINE fromRatioF #-} + +-- n > 0, d > 0 +fromPositiveRatioF :: forall a f. (RealFloat a, Result f) + => Integer -> Integer -> f a +fromPositiveRatioF !n !d + = let ln, ld, e :: Int + ln = integerLog2' n + ld = integerLog2' d + e = ln - ld - fDigits + q, r, d_ :: Integer + d_ | e >= 0 = d `unsafeShiftL` e + | otherwise = d + (!q, !r) | e >= 0 = n `quotRem` d_ + | otherwise = (n `unsafeShiftL` (-e)) `quotRem` d + -- e >= 0: n = q * (d * 2^e) + r, 0 <= r < d * 2^e + -- e <= 0: n * 2^(-e) = q * d + r, 0 <= r < d + -- n / d * 2^^(-e) = q + r / d_ + -- 52 <= log2 q < 54 + q', r', d' :: Integer + e' :: Int + (!q', !r', !d', !e') | q < (1 `unsafeShiftL` fDigits) = (q, r, d_, e) + | otherwise = let (q'', r'') = q `quotRem` 2 + in (q'', r'' * d_ + r, 2 * d_, e + 1) + -- n / d * 2^^(-e') = q' + r' / d', 2^52 <= q' < 2^53, 0 <= r' < d' + -- q' * 2^^e' <= n/d < (q'+1) * 2^^e', 2^52 <= q' < 2^53 + -- (q'/2^53) * 2^^(e'+53) <= n/d < (q'+1)/2^53 * 2^^(e'+53), 1/2 <= q'/2^53 < 1 + -- normal: 0x1p-1022 <= x <= 0x1.fffffffffffffp+1023 + in assert (n % d * 2^^(-e) == fromInteger q + r % d_) $ + assert (n % d * 2^^(-e') == fromInteger q' + r' % d') $ + if expMin <= e' + fDigits && e' + fDigits <= expMax + then + -- normal + if r' == 0 + then + exact $ encodeFloat q' e' -- exact + else + -- inexact + let down = encodeFloat q' e' + up = encodeFloat (q' + 1) e' -- may be infinity + toNearest = case compare (2 * r') d' of + LT -> down + EQ | even q' -> down + | otherwise -> up -- q' + 1 is even + GT -> up + in inexact toNearest up down down + else + -- infinity or subnormal + if expMax <= e' + fDigits + then + -- infinity + inexact (1 / 0) -- ToNearest + (1 / 0) -- TowardInf + maxFinite_ieee -- TowardNegInf + maxFinite_ieee -- TowardZero + else + -- subnormal + -- e' + fDigits < expMin (or, e' < expMin - fDigits = -1074) + -- 0 <= rounded(n/d) <= 2^(expMin - 1) = 0x1p-1022, minimum (positive) subnormal: 0x1p-1074 + let (!q'', !r'') = q' `quotRem` (1 `unsafeShiftL` (expMin - fDigits - e')) + -- q' = q'' * 2^(expMin - fDigits - e') + r'', 0 <= r'' < 2^(expMin - fDigits - e') + -- 2^(fDigits-1) <= q' = q'' * 2^(expMin - fDigits - e') + r'' < 2^fDigits + -- n / d * 2^^(-e') = q' + r' / d' = q'' * 2^(expMin - fDigits - e') + r'' + r' / d' + -- n / d = q'' * 2^^(expMin - fDigits) + (r'' + r' / d') * 2^^e' + -- 0 <= r'' < 2^(expMin - fDigits - e') + in if r' == 0 && r'' == 0 + then exact $ encodeFloat q'' (expMin - fDigits) -- exact + else let down = encodeFloat q'' (expMin - fDigits) + up = encodeFloat (q'' + 1) (expMin - fDigits) + toNearest = case compare r'' (1 `unsafeShiftL` (expMin - fDigits - e' - 1)) of + LT -> down + GT -> up + EQ | r' /= 0 -> up + | even q' -> down + | otherwise -> up + in inexact toNearest up down down + where + !fDigits = floatDigits (undefined :: a) -- 53 for Double + (!expMin, !expMax) = floatRange (undefined :: a) -- (-1021, 1024) for Double +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> DynamicRoundingMode Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> OppositeRoundingMode DynamicRoundingMode Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Rounding r => Integer -> Integer -> Rounded r Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Rounding r => Integer -> Integer -> OppositeRoundingMode (Rounded r) Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> OppositeRoundingMode (Product (Rounded 'TowardNegInf) (Rounded 'TowardInf)) Float #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> DynamicRoundingMode Double #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> OppositeRoundingMode DynamicRoundingMode Double #-} +{-# SPECIALIZE fromPositiveRatioF :: Rounding r => Integer -> Integer -> Rounded r Double #-} +{-# SPECIALIZE fromPositiveRatioF :: Rounding r => Integer -> Integer -> OppositeRoundingMode (Rounded r) Double #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> Product (Rounded 'TowardNegInf) (Rounded 'TowardInf) Double #-} +{-# SPECIALIZE fromPositiveRatioF :: Integer -> Integer -> OppositeRoundingMode (Product (Rounded 'TowardNegInf) (Rounded 'TowardInf)) Double #-} diff --git a/src/Numeric/Rounded/Hardware/Internal/FloatUtil.hs b/src/Numeric/Rounded/Hardware/Internal/FloatUtil.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/FloatUtil.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NumericUnderscores #-} +module Numeric.Rounded.Hardware.Internal.FloatUtil + ( nextUp + , nextDown + , nextTowardZero + , minPositive_ieee + , maxFinite_ieee + , distanceUlp + , fusedMultiplyAdd + ) where +import Data.Bits +import Data.Ratio +import GHC.Float (castDoubleToWord64, castFloatToWord32, + castWord32ToFloat, castWord64ToDouble) + +-- $setup +-- >>> :set -XHexFloatLiterals -XNumericUnderscores + +-- | +-- prop> (minPositive_ieee :: Double) == 0x1p-1074 +-- prop> (minPositive_ieee :: Float) == 0x1p-149 +minPositive_ieee :: RealFloat a => a +minPositive_ieee = let d = floatDigits x + (expMin,_expMax) = floatRange x + x = encodeFloat 1 (expMin - d) + in x +{-# SPECIALIZE minPositive_ieee :: Double #-} +{-# SPECIALIZE minPositive_ieee :: Float #-} + +-- | +-- prop> (maxFinite_ieee :: Double) == 0x1.ffff_ffff_ffff_fp+1023 +-- prop> (maxFinite_ieee :: Float) == 0x1.fffffep+127 +maxFinite_ieee :: RealFloat a => a +maxFinite_ieee = let d = floatDigits x + (_expMin,expMax) = floatRange x + r = floatRadix x + x = encodeFloat (r ^! d - 1) (expMax - d) + in x +{-# SPECIALIZE maxFinite_ieee :: Double #-} +{-# SPECIALIZE maxFinite_ieee :: Float #-} + +-- A variant of (^) allowing constant folding for base = 2 +infixr 8 ^! +(^!) :: Integer -> Int -> Integer +(^!) = (^) +{-# INLINE [2] (^!) #-} +{-# RULES +"2^!" forall y. 2 ^! y = staticIf (y >= 0) (1 `shiftL` y) (2 ^ y) + #-} + +staticIf :: Bool -> a -> a -> a +staticIf _ _ x = x +{-# INLINE [0] staticIf #-} +{-# RULES +"staticIf/True" forall x y. staticIf True x y = x +"staticIf/False" forall x y. staticIf False x y = y + #-} + +-- | +-- prop> nextUp 1 == (0x1.0000_0000_0000_1p0 :: Double) +-- prop> nextUp 1 == (0x1.000002p0 :: Float) +-- prop> nextUp (1/0) == (1/0 :: Double) +-- prop> nextUp (-1/0) == (- maxFinite_ieee :: Double) +-- prop> nextUp 0 == (0x1p-1074 :: Double) +-- prop> nextUp (-0) == (0x1p-1074 :: Double) +-- prop> nextUp (-0x1p-1074) == (-0 :: Double) +-- prop> isNegativeZero (nextUp (-0x1p-1074) :: Double) +nextUp :: RealFloat a => a -> a +nextUp x | not (isIEEE x) = error "non-IEEE numbers are not supported" + | floatRadix x /= 2 = error "non-binary types are not supported" + | isNaN x || (isInfinite x && x > 0) = x -- NaN or positive infinity + | x >= 0 = nextUp_ieee_positive x + | otherwise = - nextDown_ieee_positive (- x) +{-# INLINE [1] nextUp #-} + +-- | +-- prop> nextDown 1 == (0x1.ffff_ffff_ffff_fp-1 :: Double) +-- prop> nextDown 1 == (0x1.fffffep-1 :: Float) +-- prop> nextDown (1/0) == (maxFinite_ieee :: Double) +-- prop> nextDown (-1/0) == (-1/0 :: Double) +-- prop> nextDown 0 == (-0x1p-1074 :: Double) +-- prop> nextDown (-0) == (-0x1p-1074 :: Double) +-- prop> nextDown 0x1p-1074 == (0 :: Double) +nextDown :: RealFloat a => a -> a +nextDown x | not (isIEEE x) = error "non-IEEE numbers are not supported" + | floatRadix x /= 2 = error "non-binary types are not supported" + | isNaN x || (isInfinite x && x < 0) = x -- NaN or negative infinity + | x >= 0 = nextDown_ieee_positive x + | otherwise = - nextUp_ieee_positive (- x) +{-# INLINE [1] nextDown #-} + +-- | +-- prop> nextTowardZero 1 == (0x1.ffff_ffff_ffff_fp-1 :: Double) +-- prop> nextTowardZero 1 == (0x1.fffffep-1 :: Float) +-- prop> nextTowardZero (1/0) == (maxFinite_ieee :: Double) +-- prop> nextTowardZero (-1/0) == (-maxFinite_ieee :: Double) +-- prop> nextTowardZero 0 == (0 :: Double) +-- prop> isNegativeZero (nextTowardZero (-0 :: Double)) +-- prop> nextTowardZero 0x1p-1074 == (0 :: Double) +nextTowardZero :: RealFloat a => a -> a +nextTowardZero x | not (isIEEE x) = error "non-IEEE numbers are not supported" + | floatRadix x /= 2 = error "non-binary types are not supported " + | isNaN x || x == 0 = x -- NaN or zero + | x >= 0 = nextDown_ieee_positive x + | otherwise = - nextDown_ieee_positive (- x) +{-# INLINE [1] nextTowardZero #-} + +nextUp_ieee_positive :: RealFloat a => a -> a +nextUp_ieee_positive x + | isNaN x || x < 0 = error "nextUp_ieee_positive" + | isInfinite x = x + | x == 0 = encodeFloat 1 (expMin - d) -- min positive + | otherwise = let m :: Integer + e :: Int + (m,e) = decodeFloat x + -- x = m * 2^e, 2^(d-1) <= m < 2^d + -- 2^expMin < x < 2^expMax + -- 2^(expMin-d): min positive + -- 2^(expMin - 1): min normal 0x1p-1022 + -- expMin - d <= e <= expMax - d (-1074 .. 971) + in if expMin - d <= e + then encodeFloat (m + 1) e -- normal + else let m' = m `shiftR` (expMin - d - e) + in encodeFloat (m' + 1) (expMin - d) -- subnormal + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,_expMax) = floatRange x -- (-1021,1024) for Double +{-# INLINE nextUp_ieee_positive #-} + +nextDown_ieee_positive :: RealFloat a => a -> a +nextDown_ieee_positive x + | isNaN x || x < 0 = error "nextDown_ieee_positive" + | isInfinite x = encodeFloat ((1 `unsafeShiftL` d) - 1) (expMax - d) -- max finite + | x == 0 = encodeFloat (-1) (expMin - d) -- max negative + | otherwise = let m :: Integer + e :: Int + (m,e) = decodeFloat x + -- x = m * 2^e, 2^(d-1) <= m < 2^d + -- 2^expMin < x < 2^expMax + -- 2^(expMin-d): min positive + -- 2^(expMin - 1): min normal 0x1p-1022 + -- expMin - d <= e <= expMax - d (-1074 .. 971) + in if expMin - d <= e + then -- normal + let m1 = m - 1 + in if m .&. m1 == 0 + then encodeFloat (2 * m - 1) (e - 1) + else encodeFloat m1 e + else -- subnormal + let m' = m `shiftR` (expMin - d - e) + in encodeFloat (m' - 1) (expMin - d) + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double +{-# INLINE nextDown_ieee_positive #-} + +{-# RULES +"nextUp/Float" [~1] nextUp = nextUpFloat +"nextUp/Double" [~1] nextUp = nextUpDouble +"nextDown/Float" [~1] nextDown = nextDownFloat +"nextDown/Double" [~1] nextDown = nextDownDouble +"nextTowardZero/Float" [~1] nextTowardZero = nextTowardZeroFloat +"nextTowardZero/Double" [~1] nextTowardZero = nextTowardZeroDouble + #-} + +-- | +-- prop> nextUpFloat 1 == 0x1.000002p0 +-- prop> nextUpFloat (1/0) == 1/0 +-- prop> nextUpFloat (-1/0) == - maxFinite_ieee +-- prop> nextUpFloat 0 == 0x1p-149 +-- prop> nextUpFloat (-0) == 0x1p-149 +-- prop> isNegativeZero (nextUpFloat (-0x1p-149)) +nextUpFloat :: Float -> Float +nextUpFloat x + | not (isIEEE x) || floatRadix x /= 2 || d /= 24 || expMin /= -125 || expMax /= 128 = error "rounded-hw assumes Float is IEEE binary32" + | isNaN x = x -- NaN -> itself + | isNegativeZero x = encodeFloat 1 (expMin - d) -- -0 -> min positive + | x < 0 = castWord32ToFloat (castFloatToWord32 x - 1) -- negative + | otherwise = case castFloatToWord32 x of + 0x7f80_0000 -> x -- positive infinity -> itself + w -> castWord32ToFloat (w + 1) -- positive + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + -- Note: castFloatToWord32 is buggy on GHC <= 8.8 on x86_64, so we can't use it to test for NaN or negative number + -- https://gitlab.haskell.org/ghc/ghc/issues/16617 + +-- | +-- prop> nextUpDouble 1 == 0x1.0000_0000_0000_1p0 +-- prop> nextUpDouble (1/0) == 1/0 +-- prop> nextUpDouble (-1/0) == - maxFinite_ieee +-- prop> nextUpDouble 0 == 0x1p-1074 +-- prop> nextUpDouble (-0) == 0x1p-1074 +-- prop> isNegativeZero (nextUpDouble (-0x1p-1074)) +nextUpDouble :: Double -> Double +nextUpDouble x + | not (isIEEE x) || floatRadix x /= 2 || d /= 53 || expMin /= -1021 || expMax /= 1024 = error "rounded-hw assumes Double is IEEE binary64" + | otherwise = case castDoubleToWord64 x of + w | w .&. 0x7ff0_0000_0000_0000 == 0x7ff0_0000_0000_0000 + , w /= 0xfff0_0000_0000_0000 -> x -- NaN or positive infinity -> itself + 0x8000_0000_0000_0000 -> encodeFloat 1 (expMin - d) -- -0 -> min positive + w | testBit w 63 -> castWord64ToDouble (w - 1) -- negative + | otherwise -> castWord64ToDouble (w + 1) -- positive + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + +-- | +-- prop> nextDownFloat 1 == 0x1.fffffep-1 +-- prop> nextDownFloat (1/0) == maxFinite_ieee +-- prop> nextDownFloat (-1/0) == -1/0 +-- prop> nextDownFloat 0 == -0x1p-149 +-- prop> nextDownFloat (-0) == -0x1p-149 +-- prop> nextDownFloat 0x1p-149 == 0 +nextDownFloat :: Float -> Float +nextDownFloat x + | not (isIEEE x) || floatRadix x /= 2 || d /= 24 || expMin /= -125 || expMax /= 128 = error "rounded-hw assumes Float is IEEE binary32" + | isNaN x || (isInfinite x && x < 0) = x -- NaN or negative infinity -> itself + | isNegativeZero x || x < 0 = castWord32ToFloat (castFloatToWord32 x + 1) -- negative + | x == 0 = encodeFloat (-1) (expMin - d) -- +0 -> max negative + | otherwise = castWord32ToFloat (castFloatToWord32 x - 1) -- positive + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + -- Note: castFloatToWord32 is buggy on GHC <= 8.8 on x86_64, so we can't use it to test for NaN or negative number + -- https://gitlab.haskell.org/ghc/ghc/issues/16617 + +-- | +-- prop> nextDownDouble 1 == 0x1.ffff_ffff_ffff_fp-1 +-- prop> nextDownDouble (1/0) == maxFinite_ieee +-- prop> nextDownDouble (-1/0) == -1/0 +-- prop> nextDownDouble 0 == -0x1p-1074 +-- prop> nextDownDouble (-0) == -0x1p-1074 +-- prop> nextDownDouble 0x1p-1074 == 0 +nextDownDouble :: Double -> Double +nextDownDouble x + | not (isIEEE x) || floatRadix x /= 2 || d /= 53 || expMin /= -1021 || expMax /= 1024 = error "rounded-hw assumes Double is IEEE binary64" + | otherwise = case castDoubleToWord64 x of + w | w .&. 0x7ff0_0000_0000_0000 == 0x7ff0_0000_0000_0000 + , w /= 0x7ff0_0000_0000_0000 -> x -- NaN or negative infinity -> itself + 0x0000_0000_0000_0000 -> encodeFloat (-1) (expMin - d) -- +0 -> max negative + w | testBit w 63 -> castWord64ToDouble (w + 1) -- negative + | otherwise -> castWord64ToDouble (w - 1) -- positive + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + +-- | +-- prop> nextTowardZeroFloat 1 == 0x1.fffffep-1 +-- prop> nextTowardZeroFloat (-1) == -0x1.fffffep-1 +-- prop> nextTowardZeroFloat (1/0) == maxFinite_ieee +-- prop> nextTowardZeroFloat (-1/0) == -maxFinite_ieee +-- prop> nextTowardZeroFloat 0 == 0 +-- prop> isNegativeZero (nextTowardZeroFloat (-0)) +-- prop> nextTowardZeroFloat 0x1p-149 == 0 +nextTowardZeroFloat :: Float -> Float +nextTowardZeroFloat x + | not (isIEEE x) || floatRadix x /= 2 || d /= 24 || expMin /= -125 || expMax /= 128 = error "rounded-hw assumes Float is IEEE binary32" + | isNaN x || x == 0 = x -- NaN or zero -> itself + | otherwise = castWord32ToFloat (castFloatToWord32 x - 1) -- positive / negative + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + -- Note: castFloatToWord32 is buggy on GHC <= 8.8 on x86_64, so we can't use it to test for NaN or negative number + -- https://gitlab.haskell.org/ghc/ghc/issues/16617 + +-- | +-- prop> nextTowardZeroDouble 1 == 0x1.ffff_ffff_ffff_fp-1 +-- prop> nextTowardZeroDouble (-1) == -0x1.ffff_ffff_ffff_fp-1 +-- prop> nextTowardZeroDouble (1/0) == maxFinite_ieee +-- prop> nextTowardZeroDouble (-1/0) == -maxFinite_ieee +-- prop> nextTowardZeroDouble 0 == 0 +-- prop> isNegativeZero (nextTowardZeroDouble (-0)) +-- prop> nextTowardZeroDouble 0x1p-1074 == 0 +nextTowardZeroDouble :: Double -> Double +nextTowardZeroDouble x + | not (isIEEE x) || floatRadix x /= 2 || d /= 53 || expMin /= -1021 || expMax /= 1024 = error "rounded-hw assumes Double is IEEE binary64" + | otherwise = case castDoubleToWord64 x of + w | w .&. 0x7ff0_0000_0000_0000 == 0x7ff0_0000_0000_0000 + , w .&. 0x000f_ffff_ffff_ffff /= 0 -> x -- NaN -> itself + 0x8000_0000_0000_0000 -> x -- -0 -> itself + 0x0000_0000_0000_0000 -> x -- +0 -> itself + w -> castWord64ToDouble (w - 1) -- positive / negative + where + d, expMin :: Int + d = floatDigits x -- 53 for Double + (expMin,expMax) = floatRange x -- (-1021,1024) for Double + +fusedMultiplyAdd :: RealFloat a => a -> a -> a -> a +fusedMultiplyAdd x y z + | isNaN x || isNaN y || isNaN z || isInfinite x || isInfinite y || isInfinite z = x * y + z + | otherwise = case toRational x * toRational y + toRational z of + 0 | isNegativeZero (x * y + z) -> -0 + r -> fromRational r +{-# NOINLINE [1] fusedMultiplyAdd #-} + +#ifdef USE_FFI + +foreign import ccall unsafe "fmaf" + fusedMultiplyAddFloat :: Float -> Float -> Float -> Float +foreign import ccall unsafe "fma" + fusedMultiplyAddDouble :: Double -> Double -> Double -> Double + +{-# RULES +"fusedMultiplyAdd/Float" fusedMultiplyAdd = fusedMultiplyAddFloat +"fusedMultiplyAdd/Double" fusedMultiplyAdd = fusedMultiplyAddDouble + #-} + +#endif + +distanceUlp :: RealFloat a => a -> a -> Maybe Integer +distanceUlp x y + | isInfinite x || isInfinite y || isNaN x || isNaN y = Nothing + | otherwise = let m = min (abs x) (abs y) + m' = nextUp m + v = (toRational y - toRational x) / toRational (m' - m) + in if denominator v == 1 + then Just (abs (numerator v)) + else error "distanceUlp" diff --git a/src/Numeric/Rounded/Hardware/Internal/RoundedResult.hs b/src/Numeric/Rounded/Hardware/Internal/RoundedResult.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/RoundedResult.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Numeric.Rounded.Hardware.Internal.RoundedResult where +import Data.Proxy +import Data.Functor.Product +import Numeric.Rounded.Hardware.Internal.Rounding + +class Functor f => Result f where + exact :: a -> f a + inexact :: a -- toward nearest + -> a -- toward inf + -> a -- toward neg inf + -> a -- toward zero + -> f a + +newtype Exactness a = Exactness { getExactness :: Bool } + deriving (Eq, Ord, Show, Functor) + +instance Rounding r => Result (Rounded r) where + exact x = Rounded x + inexact n inf ninf z = case rounding (Proxy :: Proxy r) of + ToNearest -> Rounded n + TowardInf -> Rounded inf + TowardNegInf -> Rounded ninf + TowardZero -> Rounded z + +newtype DynamicRoundingMode a = DynamicRoundingMode { withRoundingMode :: RoundingMode -> a } + deriving (Functor) +instance Result DynamicRoundingMode where + exact x = DynamicRoundingMode (\_ -> x) + inexact n inf ninf z = DynamicRoundingMode $ \r -> + case r of + ToNearest -> n + TowardInf -> inf + TowardNegInf -> ninf + TowardZero -> z + +instance Result Exactness where + exact _ = Exactness True + inexact _ _ _ _ = Exactness False + +-- Usage: Product (Rounded TowardNegInf) (Rounded TowardInf) +instance (Result f, Result g) => Result (Product f g) where + exact x = Pair (exact x) (exact x) + inexact n inf ninf z = Pair (inexact n inf ninf z) (inexact n inf ninf z) + +newtype OppositeRoundingMode f a = OppositeRoundingMode { withOppositeRoundingMode :: f a } + deriving (Eq, Ord, Show, Functor) + +instance Result f => Result (OppositeRoundingMode f) where + exact x = OppositeRoundingMode (exact x) + inexact n inf ninf z = OppositeRoundingMode (inexact n ninf inf z) diff --git a/src/Numeric/Rounded/Hardware/Internal/Rounding.hs b/src/Numeric/Rounded/Hardware/Internal/Rounding.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/Rounding.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Internal.Rounding + ( RoundingMode(..) + , oppositeRoundingMode + , Rounding + , rounding + , reifyRounding + , Rounded(..) + , VUM.MVector(MV_Rounded) + , VU.Vector(V_Rounded) + ) where +import Control.DeepSeq (NFData (..)) +import Data.Coerce +import Data.Proxy +import Data.Tagged +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Foreign.Storable (Storable) +import GHC.Generics (Generic) + +-- See cbits/rounded.c for the ordering +-- | The type for IEEE754 rounding-direction attributes. +data RoundingMode + = ToNearest -- ^ Round to the nearest value (IEEE754 roundTiesToEven) + | TowardNegInf -- ^ Round downward (IEEE754 roundTowardNegative) + | TowardInf -- ^ Round upward (IEEE754 roundTowardPositive) + | TowardZero -- ^ Round toward zero (IEEE754 roundTowardZero) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +instance NFData RoundingMode + +-- | Returns the opposite rounding direction. +-- +-- @TowardNegInf@ and @TowardInf@ are swapped. +oppositeRoundingMode :: RoundingMode -> RoundingMode +oppositeRoundingMode ToNearest = ToNearest +oppositeRoundingMode TowardZero = TowardZero +oppositeRoundingMode TowardInf = TowardNegInf +oppositeRoundingMode TowardNegInf = TowardInf + +-- | This class allows you to recover the runtime value from a type-level rounding mode. +-- +-- See 'rounding'. +class Rounding (r :: RoundingMode) where + roundingT :: Tagged r RoundingMode + +instance Rounding 'ToNearest where + roundingT = Tagged ToNearest + +instance Rounding 'TowardInf where + roundingT = Tagged TowardInf + +instance Rounding 'TowardNegInf where + roundingT = Tagged TowardNegInf + +instance Rounding 'TowardZero where + roundingT = Tagged TowardZero + +-- | Recovers the value from type-level rounding mode. +rounding :: Rounding r => proxy r -> RoundingMode +rounding = Data.Tagged.proxy roundingT +{-# INLINE rounding #-} + +-- | Lifts a rounding mode to type-level. +reifyRounding :: RoundingMode -> (forall s. Rounding s => Proxy s -> a) -> a +reifyRounding ToNearest f = f (Proxy :: Proxy 'ToNearest) +reifyRounding TowardInf f = f (Proxy :: Proxy 'TowardInf) +reifyRounding TowardNegInf f = f (Proxy :: Proxy 'TowardNegInf) +reifyRounding TowardZero f = f (Proxy :: Proxy 'TowardZero) +{-# INLINE reifyRounding #-} + +-- | A type tagged with a rounding direction. +-- +-- The rounding direction is effective for a /single/ operation. +-- You won't get the correctly-rounded result for a compound expression like @(a - b * c) :: Rounded 'TowardInf Double@. +-- +-- In particular, a negative literal like @-0.1 :: Rounded r Double@ doesn't yield the correctly-rounded value for @-0.1@. +-- To get the correct value, call 'fromRational' explicitly (i.e. @fromRational (-0.1) :: Rounded r Double@) or use @NegativeLiterals@ extension. +newtype Rounded (r :: RoundingMode) a = Rounded { getRounded :: a } + deriving (Eq, Ord, Generic, Functor, Storable) + +instance Show a => Show (Rounded r a) where + -- TODO: Take the rounding direction into account + showsPrec prec (Rounded x) = showParen (prec > 10) $ showString "Rounded " . showsPrec 11 x + +instance NFData a => NFData (Rounded r a) + +-- Orphan instances: +-- instance Num (Rounded r a) is defined in Numeric.Rounded.Hardware.Internal.Class. +-- instance Fractional (Rounded r a) is defined in Numeric.Rounded.Hardware.Internal.Class. +-- instance Real (Rounded r a) is defined in Numeric.Rounded.Hardware.Internal.Class. +-- instance RealFrac (Rounded r a) is defined in Numeric.Rounded.Hardware.Internal.Class. +-- instance Floating (Rounded r a) is not implemented (something like CRlibm would be needed) + +newtype instance VUM.MVector s (Rounded r a) = MV_Rounded (VUM.MVector s a) +newtype instance VU.Vector (Rounded r a) = V_Rounded (VU.Vector a) + +instance VU.Unbox a => VGM.MVector VUM.MVector (Rounded r a) where + basicLength (MV_Rounded mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_Rounded mv) = MV_Rounded (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_Rounded mv) (MV_Rounded mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_Rounded <$> VGM.basicUnsafeNew l + basicInitialize (MV_Rounded mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_Rounded <$> VGM.basicUnsafeReplicate i (coerce x) + basicUnsafeRead (MV_Rounded mv) i = coerce <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_Rounded mv) i x = VGM.basicUnsafeWrite mv i (coerce x) + basicClear (MV_Rounded mv) = VGM.basicClear mv + basicSet (MV_Rounded mv) x = VGM.basicSet mv (coerce x) + basicUnsafeCopy (MV_Rounded mv) (MV_Rounded mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_Rounded mv) (MV_Rounded mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_Rounded mv) n = MV_Rounded <$> VGM.basicUnsafeGrow mv n + +instance VU.Unbox a => VG.Vector VU.Vector (Rounded r a) where + basicUnsafeFreeze (MV_Rounded mv) = V_Rounded <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_Rounded v) = MV_Rounded <$> VG.basicUnsafeThaw v + basicLength (V_Rounded v) = VG.basicLength v + basicUnsafeSlice i l (V_Rounded v) = V_Rounded (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_Rounded v) i = coerce <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Rounded mv) (V_Rounded v) = VG.basicUnsafeCopy mv v + elemseq (V_Rounded v) x y = VG.elemseq v (coerce x) y + +instance VU.Unbox a => VU.Unbox (Rounded r a) diff --git a/src/Numeric/Rounded/Hardware/Internal/Show.hs b/src/Numeric/Rounded/Hardware/Internal/Show.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Internal/Show.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Numeric.Rounded.Hardware.Internal.Show where +import Numeric.Rounded.Hardware.Internal.Rounding +import Data.Char (intToDigit) +import Data.Bifunctor (first) +import Data.Bits +import Math.NumberTheory.Logarithms + +-- $setup +-- >>> import Data.Int + +-- | +-- prop> \x -> x == 0 || countTrailingZerosInteger (fromIntegral x) == countTrailingZeros (x :: Int64) +-- >>> countTrailingZerosInteger 7 +-- 0 +-- >>> countTrailingZerosInteger 8 +-- 3 +countTrailingZerosInteger :: Integer -> Int +countTrailingZerosInteger x + | x == 0 = error "countTrailingZerosInteger: zero" + | otherwise = integerLog2 (x `xor` (x - 1)) + +-- ratToDigitsRn :: RoundingMode -> Int -> Int -> Rational -> ([Int], Int) + +-- binaryFloatToDecimalDigitsRn _ prec x = ([d1,d2,...,dn], e) +-- 0 <= n <= prec + 1, x = 0.d1d2...dn * (10^^e) up to rounding +-- 0 <= di < 10 +-- | +-- >>> binaryFloatToDecimalDigitsRn ToNearest 3 (0.125 :: Double) +-- ([1,2,5],0) +-- >>> binaryFloatToDecimalDigitsRn ToNearest 3 (12.5 :: Double) +-- ([1,2,5],2) +binaryFloatToDecimalDigitsRn :: forall a. RealFloat a + => RoundingMode -- ^ rounding mode + -> Int -- ^ prec + -> a -- ^ a non-negative number (zero, normal or subnormal) + -> ([Int], Int) +binaryFloatToDecimalDigitsRn _rm _prec 0 = ([], 0) +binaryFloatToDecimalDigitsRn _rm _prec x | floatRadix x /= 2 = error "radix must be 2" +binaryFloatToDecimalDigitsRn rm prec x = + -- x > 0 + let m :: Integer + n, d, e0 :: Int + (m,n) = decodeFloat x + d = floatDigits x -- d=53 for Double + -- x = m * 2^n, 2^(d-1) <= m < 2^d + -- 2^(-1074) <= x < 2^1024 + -- => -1074-52=-1126 <= n < 1024-52=972 + + e0 = floor (fromIntegral (d - 1 + n) * logBase 10 2 :: a) - prec + -- TODO: precision of logBase 10 2? + -- TODO: Use rational approximation for logBase 10 2? + + s, t :: Integer + (s,t) | n < 0, 0 <= e0 = (m, 2^(-n) * 10^e0) + | {- n >= 0 -} 0 <= e0 = (m * 2^n, 10^e0) + | n < 0 {- e0 < 0 -} = (m * 10^(-e0), 2^(-n)) + | otherwise = (m * 2^n * 10^(-e0), 1) + -- s/t = m * 2^n * 10^(-e0) = x * 10^(-e0) + + q, r :: Integer + (q,r) = s `quotRem` t + -- s = q * t + r + -- 10^prec <= q + r/t < 2 * 10^(prec+1) + + q', r', t' :: Integer + e' :: Int + (q',r',t',e') | 10^(prec+1) <= q = case q `quotRem` 10 of + -- q = q''*10+r'' + -- s = (q''*10+r'')*t + r = q''*10*t+(r''*t+r) + (q'',r'') -> (q'', r''*t+r, 10*t, e0+1) + | otherwise = (q,r,t,e0) + -- 10^prec <= q' + r'/t' < 10^(prec+1), 0 <= r' < t' + + -- x = m*2^n + -- = s/t * 10^^(e0) + -- = (q + r/t) * 10^^(e0) + -- = (q' + r'/t') * 10^^e' + in if r' == 0 + then + -- exact + loop0 e' q' + else + -- inexact + case rm of + TowardNegInf -> loop0 e' q' + TowardZero -> loop0 e' q' + TowardInf -> loop0 e' (q' + 1) + ToNearest -> case compare (2 * r') t' of + LT -> loop0 e' q' + EQ | even q' -> loop0 e' q' + | otherwise -> loop0 e' (q' + 1) + GT -> loop0 e' (q' + 1) + where + -- loop0 e n: x = n * 10^(e-prec-1) + loop0 :: Int -> Integer -> ([Int], Int) + loop0 !_ 0 = ([], 0) -- should not occur + loop0 !e a = case a `quotRem` 10 of + (q,0) -> loop0 (e+1) q + (q,r) -> loop (e+1) [fromInteger r] q + + -- loop e acc a: (a + 0.)*10^(e-prec-1) + loop :: Int -> [Int] -> Integer -> ([Int], Int) + loop !e acc 0 = (acc, e) + loop !e acc a = case a `quotRem` 10 of + (q,r) -> loop (e+1) (fromInteger r : acc) q +{-# SPECIALIZE binaryFloatToDecimalDigitsRn :: RoundingMode -> Int -> Double -> ([Int], Int) #-} + +-- binaryFloatToFixedDecimalDigitsRn _ prec x = [d1,d2,...,dn] +-- x = d1d2...dn * (10^^(-prec)) up to rounding +-- 0 <= di < 10 +-- | +-- >>> binaryFloatToFixedDecimalDigitsRn ToNearest 3 (0.125 :: Double) +-- [1,2,5] +-- >>> binaryFloatToFixedDecimalDigitsRn ToNearest 3 (12.5 :: Double) +-- [1,2,5,0,0] +binaryFloatToFixedDecimalDigitsRn :: forall a. RealFloat a + => RoundingMode -- ^ rounding mode + -> Int -- ^ prec + -> a -- ^ a non-negative number (zero, normal or subnormal) + -> [Int] +binaryFloatToFixedDecimalDigitsRn _rm _prec x | floatRadix x /= 2 = error "radix must be 2" +binaryFloatToFixedDecimalDigitsRn rm prec x = + let m, s, t, q, r :: Integer + e :: Int + (m,e) = decodeFloat x -- x = m*2^e + (s,t) | prec >= 0, e + prec >= 0 = (m * 2^(e+prec) * 5^prec, 1) + | prec >= 0 {- e + prec < 0 -} = (m * 5^prec, 2^(-e-prec)) + | {- prec < 0 -} e + prec >= 0 = (m * 2^(e+prec), 5^(-prec)) + | otherwise {- prec < 0, e + prec < 0 -} = (m, 2^(-e-prec) * 5^(-prec)) + -- x*10^^prec = s/t + (q,r) = s `quotRem` t + in if r == 0 + then + -- exact + loop [] q + else + -- inexact + case rm of + TowardNegInf -> loop [] q + TowardZero -> loop [] q + TowardInf -> loop [] (q + 1) + ToNearest -> case compare (2 * r) t of + LT -> loop [] q + EQ | even q -> loop [] q + | otherwise -> loop [] (q + 1) + GT -> loop [] (q + 1) + where + loop :: [Int] -> Integer -> [Int] + loop acc 0 = acc + loop acc a = case a `quotRem` 10 of + (q,r) -> loop (fromInteger r : acc) q +{-# SPECIALIZE binaryFloatToFixedDecimalDigitsRn :: RoundingMode -> Int -> Double -> [Int] #-} + +-- binaryFloatToDecimalDigits x = ([d1,d2,...,dn], e) +-- n >= 0, x = 0.d1d2...dn * (10^^e) +-- 0 <= di < 10 +-- | +-- >>> binaryFloatToDecimalDigits (0.125 :: Double) +-- ([1,2,5],0) +-- >>> binaryFloatToDecimalDigits (12.5 :: Double) +-- ([1,2,5],2) +binaryFloatToDecimalDigits :: RealFloat a + => a -- ^ a non-negative number (zero, normal or subnormal) + -> ([Int], Int) +binaryFloatToDecimalDigits 0 = ([], 0) +binaryFloatToDecimalDigits x | floatRadix x /= 2 = error "radix must be 2" +binaryFloatToDecimalDigits x = + let m, m', m'' :: Integer + n, z, n', e :: Int + (m,n) = decodeFloat x -- x = m*2^n + z = countTrailingZerosInteger m + (m',n') = (m `shiftR` z, n + z) + -- x = m*2^n = m'*2^n' + (m'',e) | n' < 0 = (m' * 5^(-n'), n') -- x = m'/2^(-n') = m'*5^(-n') / 10^(-n') + | otherwise = (m' * 2^n', 0) + -- x = m''*10^e, m'' is an integer, e <= 0 + in loop0 e m'' + where + -- x = a*10^e, a is an integer + loop0 :: Int -> Integer -> ([Int], Int) + loop0 !_ 0 = ([0], 0) -- should not occur + loop0 !e a = case a `quotRem` 10 of + (q,0) -> loop0 (e+1) q + (q,r) -> loop (e+1) [fromInteger r] q + + -- x = (a + 0.)*10^e, a is an integer + loop :: Int -> [Int] -> Integer -> ([Int], Int) + loop !e acc 0 = (acc, e) + loop !e acc n = case n `quotRem` 10 of + (q,r) -> loop (e+1) (fromInteger r : acc) q +{-# SPECIALIZE binaryFloatToDecimalDigits :: Double -> ([Int], Int) #-} + +-- TODO: Maybe implement ByteString or Text versions + +-- | +-- >>> showEFloatRn ToNearest (Just 0) (0 :: Double) "" +-- "0e0" +-- >>> showEFloatRn ToNearest Nothing (0 :: Double) "" +-- "0.0e0" +-- >>> showEFloatRn ToNearest Nothing (0.5 :: Double) "" +-- "5.0e-1" +showEFloatRn :: RealFloat a => RoundingMode -> Maybe Int -> a -> ShowS +showEFloatRn r mprec x + | isNaN x = showString "NaN" + | x < 0 || isNegativeZero x = showChar '-' . showEFloatRn (oppositeRoundingMode r) mprec (-x) + | isInfinite x = showString "Infinity" + | otherwise = let (xs,e) = case mprec of + Nothing -> binaryFloatToDecimalDigits x + Just prec -> let !prec' = max prec 0 + in first (padRight0 (prec' + 1)) $ binaryFloatToDecimalDigitsRn r prec' x + e' | all (== 0) xs = 0 + | otherwise = e - 1 + in case xs of + [] -> showString "0.0e0" -- mprec must be `Nothing` + [0] -> showString "0e0" -- mprec must be `Just 0` + [d] -> case mprec of + Nothing -> showString $ intToDigit d : '.' : '0' : 'e' : show e' + _ -> showString $ intToDigit d : 'e' : show e' + (d:ds) -> showString $ (intToDigit d : '.' : map intToDigit ds) ++ ('e' : show e') + where + padRight0 :: Int -> [Int] -> [Int] + padRight0 0 ys = ys + padRight0 !n [] = replicate n 0 + padRight0 !n (y:ys) = y : padRight0 (n - 1) ys +{-# SPECIALIZE showEFloatRn :: RoundingMode -> Maybe Int -> Double -> ShowS #-} + +-- | +-- >>> showFFloatRn ToNearest (Just 0) (0 :: Double) "" +-- "0" +-- >>> showFFloatRn ToNearest Nothing (0 :: Double) "" +-- "0.0" +-- >>> showFFloatRn ToNearest Nothing (-0 :: Double) "" +-- "-0.0" +-- >>> showFFloatRn ToNearest Nothing (-0.5 :: Double) "" +-- "-0.5" +showFFloatRn :: RealFloat a => RoundingMode -> Maybe Int -> a -> ShowS +showFFloatRn r mprec x + | isNaN x = showString "NaN" + | x < 0 || isNegativeZero x = showChar '-' . showFFloatRn (oppositeRoundingMode r) mprec (-x) + | isInfinite x = showString "Infinity" + | otherwise = case mprec of + Nothing -> let (xs,e) = binaryFloatToDecimalDigits x + l = length xs + in if e >= l + then if null xs + then showString "0.0" + else showString (map intToDigit xs ++ replicate (e - l) '0' ++ ".0") + else if e > 0 -- 0 < e < l + then if l == e -- null zs + then showString (map intToDigit xs ++ ".0") + else let (ys,zs) = splitAt (l - e) xs + ys' | null ys = [0] + | otherwise = ys + in showString (map intToDigit ys' ++ "." ++ map intToDigit zs) + else -- e < 0 + showString ("0." ++ replicate (-e) '0' ++ map intToDigit xs) + Just prec -> let prec' = max prec 0 + xs = binaryFloatToFixedDecimalDigitsRn r prec' x + l = length xs + in if prec' == 0 + then if null xs + then showString "0" + else showString $ map intToDigit xs + else if l <= prec' + then showString $ "0." ++ replicate (prec' - l) '0' ++ map intToDigit xs + else let (ys,zs) = splitAt (l - prec') xs + ys' | null ys = [0] + | otherwise = ys + in showString $ map intToDigit ys' ++ "." ++ map intToDigit zs +{-# SPECIALIZE showFFloatRn :: RoundingMode -> Maybe Int -> Double -> ShowS #-} + +showGFloatRn :: RealFloat a => RoundingMode -> Maybe Int -> a -> ShowS +showGFloatRn r mprec x | x == 0 || (0.1 <= abs x && abs x < 1e7) = showFFloatRn r mprec x -- Note that 1%10 < toRational (0.1 :: Double) + | otherwise = showEFloatRn r mprec x +{-# SPECIALIZE showGFloatRn :: RoundingMode -> Maybe Int -> Double -> ShowS #-} + +{- +showFFloatAltRn :: RoundingMode -> Maybe Int -> Double -> ShowS +showGFloatAltRn :: RoundingMode -> Maybe Int -> Double -> ShowS +-- showFloat :: RoundingMode -> Double -> ShowS +-} diff --git a/src/Numeric/Rounded/Hardware/Interval.hs b/src/Numeric/Rounded/Hardware/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Interval.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Interval + ( Interval(..) + , increasing + , maxI + , minI + , powInt + , null + , inf + , sup + , width + , widthUlp + , hull + , intersection + ) where +import Control.DeepSeq (NFData (..)) +import Control.Monad +import Control.Monad.ST +import qualified Data.Array.Base as A +import Data.Coerce +import Data.Ix +import Data.Primitive +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import GHC.Float (expm1, log1mexp, log1p, log1pexp) +import GHC.Generics (Generic) +import Numeric.Rounded.Hardware.Internal +import qualified Numeric.Rounded.Hardware.Interval.Class as C +import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as NE +import Prelude hiding (null) + +data Interval a + = I !(Rounded 'TowardNegInf a) !(Rounded 'TowardInf a) + | Empty + deriving (Show,Generic) + +instance NFData a => NFData (Interval a) + +increasing :: (forall r. Rounding r => Rounded r a -> Rounded r a) -> Interval a -> Interval a +increasing f (I a b) = I (f a) (f b) +increasing _ Empty = Empty +{-# INLINE increasing #-} + +instance (Num a, RoundedRing a) => Num (Interval a) where + (+) = liftBinaryNE (+) + (-) = liftBinaryNE (-) + negate = liftUnaryNE negate + (*) = liftBinaryNE (*) + abs = liftUnaryNE abs + signum = liftUnaryNE signum + fromInteger x = case intervalFromInteger x of + (y, y') -> I y y' + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + {-# INLINE (*) #-} + {-# INLINE abs #-} + {-# INLINE signum #-} + {-# INLINE fromInteger #-} + +instance (Num a, RoundedFractional a) => Fractional (Interval a) where + recip = liftUnaryNE recip + (/) = liftBinaryNE (/) + fromRational x = case intervalFromRational x of + (y, y') -> I y y' + {-# INLINE recip #-} + {-# INLINE (/) #-} + {-# INLINE fromRational #-} + +maxI :: Ord a => Interval a -> Interval a -> Interval a +maxI (I a a') (I b b') = I (max a b) (max a' b') +maxI _ _ = Empty +{-# SPECIALIZE maxI :: Interval Float -> Interval Float -> Interval Float #-} +{-# SPECIALIZE maxI :: Interval Double -> Interval Double -> Interval Double #-} + +minI :: Ord a => Interval a -> Interval a -> Interval a +minI (I a a') (I b b') = I (min a b) (min a' b') +minI _ _ = Empty +{-# SPECIALIZE minI :: Interval Float -> Interval Float -> Interval Float #-} +{-# SPECIALIZE minI :: Interval Double -> Interval Double -> Interval Double #-} + +powInt :: (Ord a, Num a, RoundedRing a) => Interval a -> Int -> Interval a +powInt (I a a') n | odd n || 0 <= a = I (a^n) (a'^n) + | a' <= 0 = I ((coerce (abs a'))^n) ((coerce (abs a))^n) + | otherwise = I 0 (max ((coerce (abs a))^n) (a'^n)) +powInt Empty _ = Empty +{-# SPECIALIZE powInt :: Interval Float -> Int -> Interval Float #-} +{-# SPECIALIZE powInt :: Interval Double -> Int -> Interval Double #-} + +null :: Interval a -> Bool +null Empty = True +null _ = False + +inf :: Interval a -> Rounded 'TowardNegInf a +inf (I x _) = x +inf _ = error "empty interval" + +sup :: Interval a -> Rounded 'TowardInf a +sup (I _ y) = y +sup _ = error "empty interval" + +width :: (Num a, RoundedRing a) => Interval a -> Rounded 'TowardInf a +width (I x y) = y - coerce x +width Empty = 0 + +widthUlp :: (RealFloat a) => Interval a -> Maybe Integer +widthUlp (I x y) = distanceUlp (getRounded x) (getRounded y) +widthUlp Empty = Just 0 + +hull :: RoundedRing a => Interval a -> Interval a -> Interval a +hull (I x y) (I x' y') = I (min x x') (max y y') +hull Empty v = v +hull u Empty = u + +intersection :: RoundedRing a => Interval a -> Interval a -> Interval a +intersection (I x y) (I x' y') | getRounded x'' <= getRounded y'' = I x'' y'' + where x'' = max x x' + y'' = min y y' +intersection _ _ = Empty + +liftUnaryNE :: (NE.Interval a -> NE.Interval a) -> Interval a -> Interval a +liftUnaryNE f (I x x') = case f (NE.I x x') of + NE.I y y' -> I y y' +liftUnaryNE _f Empty = Empty +{-# INLINE [1] liftUnaryNE #-} + +liftBinaryNE :: (NE.Interval a -> NE.Interval a -> NE.Interval a) -> Interval a -> Interval a -> Interval a +liftBinaryNE f (I x x') (I y y') = case f (NE.I x x') (NE.I y y') of + NE.I z z' -> I z z' +liftBinaryNE _f _ _ = Empty +{-# INLINE [1] liftBinaryNE #-} + +instance (Num a, RoundedFractional a, RoundedSqrt a, Eq a, RealFloat a, RealFloatConstants a) => Floating (Interval a) where + pi = I pi_down pi_up + exp = liftUnaryNE exp + log = liftUnaryNE log + sqrt = liftUnaryNE sqrt + (**) = liftBinaryNE (**) + logBase = liftBinaryNE logBase + sin = liftUnaryNE sin + cos = liftUnaryNE cos + tan = liftUnaryNE tan + asin = liftUnaryNE asin + acos = liftUnaryNE acos + atan = liftUnaryNE atan + sinh = liftUnaryNE sinh + cosh = liftUnaryNE cosh + tanh = liftUnaryNE tanh + asinh = liftUnaryNE asinh + acosh = liftUnaryNE acosh + atanh = liftUnaryNE atanh + log1p = liftUnaryNE log1p + expm1 = liftUnaryNE expm1 + log1pexp = liftUnaryNE log1pexp + log1mexp = liftUnaryNE log1mexp + {-# INLINE exp #-} + {-# INLINE log #-} + {-# INLINE sqrt #-} + {-# INLINE (**) #-} + {-# INLINE logBase #-} + {-# INLINE sin #-} + {-# INLINE cos #-} + {-# INLINE tan #-} + {-# INLINE asin #-} + {-# INLINE acos #-} + {-# INLINE atan #-} + {-# INLINE sinh #-} + {-# INLINE cosh #-} + {-# INLINE tanh #-} + {-# INLINE asinh #-} + {-# INLINE acosh #-} + {-# INLINE atanh #-} + {-# INLINE log1p #-} + {-# INLINE expm1 #-} + {-# INLINE log1pexp #-} + {-# INLINE log1mexp #-} + +instance (Num a, RoundedRing a, RealFloat a) => C.IsInterval (Interval a) where + type EndPoint (Interval a) = a + makeInterval = I + width = width + withEndPoints f (I x y) = f x y + withEndPoints _ Empty = Empty + hull = hull + intersection = intersection + maybeIntersection x y = case intersection x y of + Empty -> Nothing + z -> Just z + equalAsSet (I x y) (I x' y') = x == x' && y == y' + equalAsSet Empty Empty = True + equalAsSet _ _ = False + subset (I x y) (I x' y') = x' <= x && y <= y' + subset Empty _ = True + subset I{} Empty = False + weaklyLess (I x y) (I x' y') = x <= x' && y <= y' + weaklyLess Empty Empty = True + weaklyLess _ _ = False + precedes (I _ y) (I x' _) = getRounded y <= getRounded x' + precedes _ _ = True + interior (I x y) (I x' y') = getRounded x' <# getRounded x && getRounded y <# getRounded y' + where s <# t = s < t || (s == t && isInfinite s) + interior Empty _ = True + interior I{} Empty = False + strictLess (I x y) (I x' y') = getRounded x <# getRounded x' && getRounded y <# getRounded y' + where s <# t = s < t || (s == t && isInfinite s) + strictLess Empty Empty = True + strictLess _ _ = False + strictPrecedes (I _ y) (I x' _) = getRounded y < getRounded x' + strictPrecedes _ _ = True + disjoint (I x y) (I x' y') = getRounded y < getRounded x' || getRounded y' < getRounded x + disjoint _ _ = True + +-- +-- Instance for Data.Vector.Unboxed.Unbox +-- + +newtype instance VUM.MVector s (Interval a) = MV_Interval (VUM.MVector s (a, a)) +newtype instance VU.Vector (Interval a) = V_Interval (VU.Vector (a, a)) + +intervalToPair :: Fractional a => Interval a -> (a, a) +intervalToPair (I (Rounded x) (Rounded y)) = (x, y) +intervalToPair Empty = (1/0, -1/0) +{-# INLINE intervalToPair #-} + +pairToInterval :: Ord a => (a, a) -> Interval a +pairToInterval (x, y) | y < x = Empty + | otherwise = I (Rounded x) (Rounded y) +{-# INLINE pairToInterval #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VGM.MVector VUM.MVector (Interval a) where + basicLength (MV_Interval mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_Interval mv) = MV_Interval (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_Interval mv) (MV_Interval mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_Interval <$> VGM.basicUnsafeNew l + basicInitialize (MV_Interval mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_Interval <$> VGM.basicUnsafeReplicate i (intervalToPair x) + basicUnsafeRead (MV_Interval mv) i = pairToInterval <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_Interval mv) i x = VGM.basicUnsafeWrite mv i (intervalToPair x) + basicClear (MV_Interval mv) = VGM.basicClear mv + basicSet (MV_Interval mv) x = VGM.basicSet mv (intervalToPair x) + basicUnsafeCopy (MV_Interval mv) (MV_Interval mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_Interval mv) (MV_Interval mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_Interval mv) n = MV_Interval <$> VGM.basicUnsafeGrow mv n + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeMove #-} + {-# INLINE basicUnsafeGrow #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VG.Vector VU.Vector (Interval a) where + basicUnsafeFreeze (MV_Interval mv) = V_Interval <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_Interval v) = MV_Interval <$> VG.basicUnsafeThaw v + basicLength (V_Interval v) = VG.basicLength v + basicUnsafeSlice i l (V_Interval v) = V_Interval (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_Interval v) i = pairToInterval <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Interval mv) (V_Interval v) = VG.basicUnsafeCopy mv v + elemseq (V_Interval _) x y = x `seq` y + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE elemseq #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VU.Unbox (Interval a) + +-- +-- Instances for Data.Array.Unboxed +-- + +instance (Prim a, Ord a, Fractional a) => A.MArray (A.STUArray s) (Interval a) (ST s) where + getBounds (A.STUArray l u _ _) = return (l, u) + getNumElements (A.STUArray _ _ n _) = return n + -- newArray: Use default + unsafeNewArray_ = A.newArray_ + newArray_ bounds@(l,u) = do + let n = rangeSize bounds + arr@(MutableByteArray arr_) <- newByteArray (2 * sizeOf (undefined :: a) * n) + setByteArray arr 0 (2 * n) (0 :: a) + return (A.STUArray l u n arr_) + unsafeRead (A.STUArray _ _ _ byteArr) i = do + x <- readByteArray (MutableByteArray byteArr) (2 * i) + y <- readByteArray (MutableByteArray byteArr) (2 * i + 1) + return (pairToInterval (x, y)) + unsafeWrite (A.STUArray _ _ _ byteArr) i e = do + let (x, y) = intervalToPair e + writeByteArray (MutableByteArray byteArr) (2 * i) x + writeByteArray (MutableByteArray byteArr) (2 * i + 1) y + +instance (Prim a, Ord a, Fractional a) => A.IArray A.UArray (Interval a) where + bounds (A.UArray l u _ _) = (l,u) + numElements (A.UArray _ _ n _) = n + unsafeArray bounds el = runST $ do + marr <- A.newArray_ bounds + forM_ el $ \(i,e) -> A.unsafeWrite marr i e + A.unsafeFreezeSTUArray marr + unsafeAt (A.UArray _ _ _ byteArr) i = + let x = indexByteArray (ByteArray byteArr) (2 * i) + y = indexByteArray (ByteArray byteArr) (2 * i + 1) + in pairToInterval (x, y) + -- unsafeReplace, unsafeAccum, unsafeAccumArray: Use default diff --git a/src/Numeric/Rounded/Hardware/Interval/Class.hs b/src/Numeric/Rounded/Hardware/Interval/Class.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Interval/Class.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Interval.Class where +import Numeric.Rounded.Hardware.Internal + +infix 4 `equalAsSet`, `subset`, `weaklyLess`, `precedes`, `interior`, `strictLess`, `strictPrecedes`, `disjoint` + +class IsInterval i where + type EndPoint i + withEndPoints :: (Rounded 'TowardNegInf (EndPoint i) -> Rounded 'TowardInf (EndPoint i) -> i) -> i -> i + singleton :: EndPoint i -> i + makeInterval :: Rounded 'TowardNegInf (EndPoint i) -> Rounded 'TowardInf (EndPoint i) -> i + width :: i -> Rounded 'TowardInf (EndPoint i) + hull :: i -> i -> i + intersection :: i -> i -> i + maybeIntersection :: i -> i -> Maybe i + + equalAsSet :: i -> i -> Bool + -- | @a@ is a subset of @b@ + subset :: i -- ^ @a@ + -> i -- ^ @b@ + -> Bool + weaklyLess :: i -> i -> Bool + precedes :: i -> i -> Bool + interior :: i -> i -> Bool + strictLess :: i -> i -> Bool + strictPrecedes :: i -> i -> Bool + disjoint :: i -> i -> Bool + + -- default definition + singleton x = makeInterval (Rounded x) (Rounded x) diff --git a/src/Numeric/Rounded/Hardware/Interval/ElementaryFunctions.hs b/src/Numeric/Rounded/Hardware/Interval/ElementaryFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Interval/ElementaryFunctions.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Numeric.Rounded.Hardware.Interval.ElementaryFunctions where +import Control.Exception (assert) +import Numeric.Rounded.Hardware.Internal +import Numeric.Rounded.Hardware.Interval.Class + +sqrtI :: (IsInterval i, RoundedSqrt (EndPoint i)) => i -> i +sqrtI = withEndPoints $ \x y -> case intervalSqrt x y of (u, v) -> makeInterval u v +{-# INLINE sqrtI #-} + +expP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => EndPoint i -> i +expP x | isInfinite x = if x > 0 + then makeInterval (Rounded maxFinite) (Rounded positiveInfinity) + else makeInterval (Rounded 0) (Rounded minPositive) +expP x = let a = round x + b = x - fromInteger a -- -1/2 <= b && b <= 1/2 + b' = singleton b + series :: Int -> i -> i + series n acc | n == 0 = acc + | otherwise = series (n-1) $ 1 + acc * b' / fromIntegral n + in assert (fromInteger a + b == x && abs b <= 0.5) $ + (makeInterval exp1_down exp1_up)^^a * series 15 (makeInterval expm1_2_down exp1_2_up) +{-# INLINABLE expP #-} + +expI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => i -> i +expI = withEndPoints (\(Rounded x) (Rounded y) -> hull (expP x) (expP y)) -- increasing +{-# INLINABLE expI #-} + +expm1P :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => EndPoint i -> i +expm1P x | -0.5 <= x && x <= 0.5 = let b' = singleton x + series :: Int -> i -> i + series n acc | n == 1 = acc * b' + | otherwise = series (n-1) $ 1 + acc * b' / fromIntegral n + in series 15 (makeInterval expm1_2_down exp1_2_up) + | otherwise = expP x - 1 +{-# INLINABLE expm1P #-} + +expm1I :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => i -> i +expm1I = withEndPoints (\(Rounded x) (Rounded y) -> hull (expm1P x) (expm1P y)) -- increasing +{-# INLINABLE expm1I #-} + +logP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +logP x + | floatRadix (undefined :: EndPoint i) /= 2 = error "Unsupported float radix" + | x < 0 = error "Negative logarithm" + | x == 0 = makeInterval (Rounded negativeInfinity) (Rounded (-maxFinite)) + | isInfinite x = makeInterval (Rounded maxFinite) (Rounded positiveInfinity) + | isNaN x = error "NaN" + | otherwise = let m :: Integer + n :: Int + (m,n) = decodeFloat x + -- x = m * 2^n, 2^(d-1) <= m < 2^d + -- x = (m * 2^(-d)) * 2^(n+d) + -- x = 2^a * b, a \in {.. -1.5, -1, -0.5, 0, 0.5, 1, 1.5 ..}, 1/\sqrt{2} < b < \sqrt{2} + a0, b, bm1 :: i + a0 = fromIntegral (n + d) -- fromIntegral (exponent x) + x' :: EndPoint i + x' = encodeFloat m (- d) -- significand x + -- 0.5 <= x' < 1 + (a,b) | 0.5 <= x' && x' <= getRounded two_minus_sqrt2_down = (a0 - 1, singleton x' * 2) -- 1/2 <= x <= 2 - sqrt 2 => 1 <= 2*x <= 4 - 2 * sqrt 2 + | getRounded two_minus_sqrt2_up <= x' && x' <= 2 * getRounded sqrt2m1_down = (a0 - 0.5, singleton x' * sqrt2_iv) -- 2 - sqrt2 <= x <= 2 * sqrt 2 - 2, 2 * sqrt 2 - 2 <= sqrt 2 * x <= 4 - 2 * sqrt 2 + | 2 * getRounded sqrt2m1_up <= x' && x' < 1 = (a0, singleton x') -- 2 * sqrt 2 - 2 <= x + | otherwise = error "interval log: internal error" + -- 2 * sqrt 2 - 2 <= b <= 4 - 2 * sqrt 2 + -- 2 * sqrt 2 - 3 <= b-1 <= 3 - 2 * sqrt 2 + bm1 = b - 1 + series :: Int -> i -> i + series k acc | k == 0 = bm1 * acc + | otherwise = series (k-1) $ recip (fromIntegral k) - bm1 * acc + in a * log2_iv + series 21 (hull 1 b ^^ (-22 :: Int) * bm1 / fromInteger 22) + where + d = floatDigits (undefined :: EndPoint i) + log2_iv :: i -- log_e 2 + log2_iv = makeInterval log2_down log2_up + sqrt2_iv :: i -- sqrt 2 + sqrt2_iv = makeInterval sqrt2_down sqrt2_up +{-# INLINABLE logP #-} + +logI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +logI = withEndPoints (\(Rounded x) (Rounded y) -> hull (logP x) (logP y)) -- increasing +{-# INLINABLE logI #-} + +log1pP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +log1pP x | - getRounded three_minus_2sqrt2_down <= x && x <= getRounded three_minus_2sqrt2_down = + let x' :: i + x' = singleton x + series :: Int -> i -> i + series k acc | k == 0 = x' * acc + | otherwise = series (k-1) $ recip (fromIntegral k) - x' * acc + in series 21 (hull 1 (x' + 1) ^^ (-22 :: Int) * x' / fromInteger 22) + | otherwise = logI (singleton x + 1) +{-# INLINABLE log1pP #-} + +log1pI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +log1pI = withEndPoints (\(Rounded x) (Rounded y) -> hull (log1pP x) (log1pP y)) -- increasing +{-# INLINABLE log1pI #-} + +-- abs x <= pi / 4 +sin_small :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +sin_small x = let xx = x * x + series :: Int -> i -> i + series k acc | k == 0 = x * acc + | otherwise = series (k-2) $ 1 - xx * acc / fromIntegral (k * (k+1)) + in series 18 (makeInterval (-1) 1) +{-# INLINABLE sin_small #-} + +-- abs x <= pi / 4 +cos_small :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +cos_small x = let xx = x * x + series :: Int -> i -> i + series k acc | k == 1 = acc + | otherwise = series (k-2) $ 1 - xx * acc / fromIntegral ((k-1) * (k-2)) + in series 17 (makeInterval (-1) 1) +{-# INLINABLE cos_small #-} + +-- -pi <= x <= pi +-- x should be a small interval +sinP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +sinP x | x `weaklyLess` - three_pi_iv / 4 = - sin_small (x + pi_iv) -- -pi <= x <= -3/4*pi + | x `weaklyLess` - pi_iv / 2 = - cos_small (- pi_iv / 2 - x) -- -3/4*pi <= x <= -pi/2 + | x `weaklyLess` - pi_iv / 4 = - cos_small (x + pi_iv / 2) -- -pi <= x <= -pi/4 + | x `weaklyLess` 0 = - sin_small (- x) + | x `weaklyLess` pi_iv / 4 = sin_small x + | x `weaklyLess` pi_iv / 2 = cos_small (pi_iv / 2 - x) + | x `weaklyLess` three_pi_iv / 4 = cos_small (x - pi_iv / 2) + | otherwise = sin_small (pi_iv - x) + where + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + three_pi_iv :: i + three_pi_iv = makeInterval three_pi_down three_pi_up + -- TODO: Is `weaklyLess` okay? +{-# INLINABLE sinP #-} + +-- -pi <= x <= pi +-- x should be a small interval +cosP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +cosP x | x `weaklyLess` - three_pi_iv / 4 = - cos_small (x + pi_iv) -- -pi <= x <= -3/4*pi + | x `weaklyLess` - pi_iv / 2 = - sin_small (- pi_iv / 2 - x) -- -3/4*pi <= x <= -pi/2 + | x `weaklyLess` - pi_iv / 4 = sin_small (x + pi_iv / 2) -- -pi <= x <= -pi/4 + | x `weaklyLess` 0 = cos_small (- x) + | x `weaklyLess` pi_iv / 4 = cos_small x + | x `weaklyLess` pi_iv / 2 = sin_small (pi_iv / 2 - x) + | x `weaklyLess` three_pi_iv / 4 = - sin_small (x - pi_iv / 2) + | otherwise = - cos_small (pi_iv - x) + where + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + three_pi_iv :: i + three_pi_iv = makeInterval three_pi_down three_pi_up + -- TODO: Is `weaklyLess` okay? +{-# INLINABLE cosP #-} + +sinI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +sinI t = flip withEndPoints t $ \(Rounded x) (Rounded y) -> + if isInfinite x || isInfinite y + then wholeRange + else flip withEndPoints (singleton x / (2 * pi_iv)) $ \(Rounded x0) (Rounded _) -> + let n = round x0 + t' = t - 2 * pi_iv * fromInteger n + in flip withEndPoints t' $ \(Rounded x') (Rounded y') -> + if y' - x' >= getRounded (2 * pi_up) + then wholeRange + else -- -pi <= x' <= pi, x' <= y' <= 3 * pi + let include_minus_1 = minus_half_pi_iv `subset` t' || three_pi_2_iv `subset` t' + include_plus_1 = pi_iv / 2 `subset` t' || five_pi_2_iv `subset` t' + u = hull (sinP $ singleton x') $ sinP (if y <= getRounded pi_down then singleton y' else singleton y' - 2 * pi_iv) + v | include_minus_1 = hull (-1) u + | otherwise = u + w | include_plus_1 = hull 1 v + | otherwise = v + in intersection wholeRange w + where + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + minus_half_pi_iv :: i + minus_half_pi_iv = - pi_iv / 2 + three_pi_2_iv :: i + three_pi_2_iv = makeInterval three_pi_down three_pi_up / 2 + five_pi_2_iv :: i + five_pi_2_iv = makeInterval five_pi_down five_pi_up / 2 + wholeRange :: i + wholeRange = makeInterval (-1) 1 +{-# INLINABLE sinI #-} + +cosI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +cosI t = flip withEndPoints t $ \(Rounded x) (Rounded y) -> + if isInfinite x || isInfinite y + then wholeRange + else flip withEndPoints (singleton x / (2 * pi_iv)) $ \(Rounded x0) (Rounded _) -> + let n = round x0 + t' = t - 2 * pi_iv * fromInteger n + in flip withEndPoints t' $ \(Rounded x') (Rounded y') -> + if y' - x' >= getRounded (2 * pi_up) + then wholeRange + else -- -pi <= x' <= pi, x' <= y' <= 3 * pi + let include_minus_1 = -pi_iv `subset` t' || pi_iv `subset` t' || three_pi_iv `subset` t' + include_plus_1 = 0 `subset` t' || 2 * pi_iv `subset` t' + u = hull (cosP $ singleton x') $ cosP (if y <= getRounded pi_down then singleton y' else singleton y' - 2 * pi_iv) + v | include_minus_1 = hull (-1) u + | otherwise = u + w | include_plus_1 = hull 1 v + | otherwise = v + in intersection wholeRange w + where + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + three_pi_iv :: i + three_pi_iv = makeInterval three_pi_down three_pi_up + wholeRange :: i + wholeRange = makeInterval (-1) 1 +{-# INLINABLE cosI #-} + +tanI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +tanI t = flip withEndPoints t $ \(Rounded x) (Rounded y) -> + if isInfinite x || isInfinite y + then wholeRange + else flip withEndPoints (t / pi_iv) $ \(Rounded x0) (Rounded _) -> + let n = round x0 -- abs (x - n) <= 1/2 + t' = t - pi_iv * fromInteger n + in flip withEndPoints t' $ \(Rounded x') (Rounded y') -> + -- -pi/2 < x' < pi/2 + if y' >= getRounded pi_up / 2 + then wholeRange + else let lb = sinP (singleton x') / cosP (singleton x') + ub = sinP (singleton y') / cosP (singleton y') + -- lb <= ub + in hull lb ub -- increasing in (-pi/2,pi/2) + where + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + wholeRange :: i + wholeRange = makeInterval (Rounded negativeInfinity) (Rounded positiveInfinity) +{-# INLINABLE tanI #-} + +-- abs x <= 1 / (1 + sqrt 2) = sqrt 2 - 1 +atan_small :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +atan_small x = let n = 39 -- odd + in series n (makeInterval (-1) 1 / fromIntegral n) + where + xx = x * x + series :: Int -> i -> i + series k acc | k == 1 = x * acc + | otherwise = series (k-2) $ recip (fromIntegral (k-2)) - xx * acc +{-# INLINABLE atan_small #-} + +atanP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +atanP x | getRounded (1 + sqrt2_up) <= x = pi_iv / 2 - atan_small (recip x') + | getRounded sqrt2m1_up <= x = pi_iv / 4 + atan_small ((x' - 1) / (x' + 1)) + | - getRounded sqrt2m1_down <= x = atan_small x' + | - getRounded (sqrt2_down + 1) <= x = - pi_iv / 4 + atan_small ((1 + x') / (1 - x')) + | otherwise = - pi_iv / 2 - atan_small (recip x') + where + x' = singleton x + pi_iv :: i + pi_iv = makeInterval pi_down pi_up +{-# INLINABLE atanP #-} + +atanI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +atanI = withEndPoints (\(Rounded x) (Rounded y) -> hull (atanP x) (atanP y)) -- increasing +{-# INLINABLE atanI #-} + +asinP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RoundedSqrt (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +asinP x | x < -1 || 1 < x = error "asin" + | x == -1 = - pi_iv / 2 + | x == 1 = pi_iv / 2 + | otherwise = atanI (x' / sqrtI (1 - x'*x')) -- TODO: Use sqrt ((1+x')*(1-x')) when |x| is near 1 + where + x' = singleton x + pi_iv :: i + pi_iv = makeInterval pi_down pi_up +{-# INLINABLE asinP #-} + +asinI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RoundedSqrt (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +asinI = withEndPoints (\(Rounded x) (Rounded y) -> hull (asinP x) (asinP y)) -- increasing +{-# INLINABLE asinI #-} + +acosP :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RoundedSqrt (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +acosP x | x < -1 || 1 < x = error "asin" + | x == -1 = pi_iv + | x == 1 = 0 + | otherwise = case x' / sqrtI (1 - x'*x') of -- TODO: Use sqrt ((1+x')*(1-x')) when |x| is near 1 + y' | one_plus_sqrt2 `weaklyLess` y' -> atan_small (recip y') + | sqrt2_minus_one `weaklyLess` y' -> pi_iv / 4 - atan_small ((y' - 1) / (y' + 1)) + | - sqrt2_minus_one `weaklyLess` y' -> pi_iv / 2 - atan_small y' + | - one_plus_sqrt2 `weaklyLess` y' -> three_pi_iv / 4 - atan_small ((1 + y') / (1 - y')) + | otherwise -> pi_iv + atan_small (recip y') + -- == pi_iv / 2 - atanI y' + where + x' = singleton x + pi_iv :: i + pi_iv = makeInterval pi_down pi_up + three_pi_iv :: i + three_pi_iv = makeInterval three_pi_down three_pi_up + one_plus_sqrt2 :: i + one_plus_sqrt2 = 1 + makeInterval sqrt2_down sqrt2_up + sqrt2_minus_one :: i + sqrt2_minus_one = makeInterval sqrt2m1_down sqrt2m1_up +{-# INLINABLE acosP #-} + +acosI :: forall i. (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RoundedRing (EndPoint i), RoundedSqrt (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +acosI = withEndPoints (\(Rounded x) (Rounded y) -> hull (acosP x) (acosP y)) -- decreasing +{-# INLINABLE acosI #-} + +sinhP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => EndPoint i -> i +sinhP x | x >= 0 = let y = expP x + in (y - recip y) / 2 + | otherwise = let y = expP (- x) + in (recip y - y) / 2 + -- TODO: precision when x ~ 0 +{-# INLINABLE sinhP #-} + +sinhI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => i -> i +sinhI = withEndPoints (\(Rounded x) (Rounded y) -> hull (sinhP x) (sinhP y)) -- increasing +{-# INLINABLE sinhI #-} + +coshP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => EndPoint i -> i +coshP x | x >= 0 = let y = expP x + in (y + recip y) / 2 + | otherwise = let y = expP (- x) + in (recip y + y) / 2 +{-# INLINABLE coshP #-} + +coshI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => i -> i +coshI = withEndPoints $ \(Rounded x) (Rounded y) -> + let z = hull (coshP x) (coshP y) + in if x <= 0 && 0 <= y + then hull 0 z + else z +{-# INLINABLE coshI #-} + +tanhP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => EndPoint i -> i +tanhP x | -0.5 <= x && x <= 0.5 = sinhP x / coshP x + | 0 < x = 1 - 2 / (1 + expP (2 * x)) -- assuming 2*x is exact + | otherwise = 2 / (1 + expP (- 2 * x)) - 1 -- assuming 2*x is exact +{-# INLINABLE tanhP #-} + +tanhI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedFractional (EndPoint i)) => i -> i +tanhI = withEndPoints $ \(Rounded x) (Rounded y) -> hull (tanhP x) (tanhP y) -- increasing +{-# INLINABLE tanhI #-} + +asinhP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedSqrt (EndPoint i)) => EndPoint i -> i +asinhP x = let x' = singleton x + in logI (x' + sqrtI (1 + x' ^ (2 :: Int))) +-- TODO: precision when x ~ 0 +{-# INLINABLE asinhP #-} + +asinhI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedSqrt (EndPoint i)) => i -> i +asinhI = withEndPoints $ \(Rounded x) (Rounded y) -> hull (asinhP x) (asinhP y) -- increasing +{-# INLINABLE asinhI #-} + +acoshP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedSqrt (EndPoint i)) => EndPoint i -> i +acoshP x | x < 1 = error "acosh: domain" + | otherwise = let x' = singleton x + in logI (x' + sqrtI (x' ^ (2 :: Int) - 1)) +-- TODO: precision when x ~ 1 +{-# INLINABLE acoshP #-} + +acoshI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i), RoundedSqrt (EndPoint i)) => i -> i +acoshI = withEndPoints $ \(Rounded x) (Rounded y) -> hull (acoshP x) (acoshP y) -- increasing +{-# INLINABLE acoshI #-} + +atanhP :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => EndPoint i -> i +atanhP x | x < -1 || 1 < x = error "atanh: domain" + | x == -1 = - makeInterval (Rounded maxFinite) (Rounded positiveInfinity) + | x == 1 = makeInterval (Rounded maxFinite) (Rounded positiveInfinity) + | otherwise = let x' = singleton x + in logI ((1 + x') / (1 - x')) / 2 +{-# INLINABLE atanhP #-} + +atanhI :: (IsInterval i, Fractional i, Eq (EndPoint i), RealFloat (EndPoint i), RealFloatConstants (EndPoint i)) => i -> i +atanhI = withEndPoints $ \(Rounded x) (Rounded y) -> hull (atanhP x) (atanhP y) -- increasing +{-# INLINABLE atanhI #-} diff --git a/src/Numeric/Rounded/Hardware/Interval/NonEmpty.hs b/src/Numeric/Rounded/Hardware/Interval/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Interval/NonEmpty.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Numeric.Rounded.Hardware.Interval.NonEmpty + ( Interval(..) + , increasing + , maxI + , minI + , powInt + , null + , inf + , sup + , width + , hull + ) where +import Control.DeepSeq (NFData (..)) +import Control.Monad +import Control.Monad.ST +import qualified Data.Array.Base as A +import Data.Coerce +import Data.Ix +import Data.Primitive +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import GHC.Float (log1p, expm1) +import GHC.Generics (Generic) +import Numeric.Rounded.Hardware.Internal +import qualified Numeric.Rounded.Hardware.Interval.Class as C +import qualified Numeric.Rounded.Hardware.Interval.ElementaryFunctions as C +import Prelude hiding (null) + +data Interval a + = I !(Rounded 'TowardNegInf a) !(Rounded 'TowardInf a) + deriving (Show,Generic) + +instance NFData a => NFData (Interval a) + +increasing :: (forall r. Rounding r => Rounded r a -> Rounded r a) -> Interval a -> Interval a +increasing f (I a b) = I (f a) (f b) + +negateI :: (Num a, RoundedRing a) => Interval a -> Interval a +negateI (I a b) = I (negate (coerce b)) (negate (coerce a)) +{-# INLINE [0] negateI #-} + +addI, subI, mulI :: (Num a, RoundedRing a) => Interval a -> Interval a -> Interval a +I a b `addI` I a' b' = case intervalAdd a b a' b' of + (a'', b'') -> I a'' b'' +I a b `subI` I a' b' = case intervalSub a b a' b' of + (a'', b'') -> I a'' b'' +I a b `mulI` I a' b' = case intervalMul a b a' b' of + (a'', b'') -> I a'' b'' + +mulAddI :: (Num a, RoundedRing a) => Interval a -> Interval a -> Interval a -> Interval a +mulAddI (I a b) (I a' b') (I a'' b'') = case intervalMulAdd a b a' b' a'' b'' of + (x, y) -> I x y + +normalizeDivisor :: (Ord a, Num a) => Interval a -> Interval a +normalizeDivisor x@(I (Rounded a) (Rounded b)) + | 0 < a || b < 0 = x + | a == 0 && 0 < b = I (Rounded 0) (Rounded b) + | a < 0 && b == 0 = I (Rounded a) (Rounded (-0)) + | otherwise = error "divide by zero" + +divI :: (Num a, RoundedFractional a) => Interval a -> Interval a -> Interval a +I a b `divI` y = let I a' b' = normalizeDivisor y + (z, z') = intervalDiv a b a' b' + in I z z' + +divAddI :: (Num a, RoundedFractional a) => Interval a -> Interval a -> Interval a -> Interval a +divAddI (I a b) y (I a'' b'') = let I a' b' = normalizeDivisor y + (z, z') = intervalDivAdd a b a' b' a'' b'' + in I z z' + +{-# INLINE [0] addI #-} +{-# INLINE [0] subI #-} +{-# INLINE [0] mulI #-} +{-# INLINE [0] divI #-} +{-# INLINE mulAddI #-} +{-# INLINE divAddI #-} +{-# RULES +"Interval.NonEmpty/x*y+z" forall x y z. addI (mulI x y) z = mulAddI x y z +"Interval.NonEmpty/z+x*y" forall x y z. addI z (mulI x y) = mulAddI x y z +"Interval.NonEmpty/x*y-z" forall x y z. subI (mulI x y) z = mulAddI x y (negateI z) +"Interval.NonEmpty/z-x*y" forall x y z. subI z (mulI x y) = negateI (mulAddI x y (negateI z)) +"Interval.NonEmpty/x/y+z" forall x y z. addI (divI x y) z = divAddI x y z +"Interval.NonEmpty/z+x/y" forall x y z. addI z (divI x y) = divAddI x y z +"Interval.NonEmpty/x/y-z" forall x y z. subI (divI x y) z = divAddI x y (negateI z) +"Interval.NonEmpty/z-x/y" forall x y z. subI z (divI x y) = negateI (divAddI x y (negateI z)) +"Interval.NonEmpty/negate-negate" forall x. negateI (negateI x) = x +"Interval.NonEmpty/x+(-y)" forall x y. addI x (negateI y) = subI x y +"Interval.NonEmpty/(-y)+x" forall x y. addI (negateI y) x = subI x y +"Interval.NonEmpty/x-(-y)" forall x y. subI x (negateI y) = addI x y + #-} + +instance (Num a, RoundedRing a) => Num (Interval a) where + (+) = addI + (-) = subI + (*) = mulI + negate = negateI + abs x@(I a b) + | a >= 0 = x + | b <= 0 = negate x + | otherwise = I 0 (max (negate (coerce a)) b) + signum = increasing signum + fromInteger x = case intervalFromInteger x of + (y, y') -> I y y' + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + {-# INLINE (*) #-} + {-# INLINE abs #-} + {-# INLINE signum #-} + {-# INLINE fromInteger #-} + +instance (Num a, RoundedFractional a) => Fractional (Interval a) where + recip x = let I a b = normalizeDivisor x + (y, y') = intervalRecip a b + in I y y' + (/) = divI + fromRational x = case intervalFromRational x of + (y, y') -> I y y' + {-# INLINE recip #-} + {-# INLINE (/) #-} + {-# INLINE fromRational #-} + +maxI :: Ord a => Interval a -> Interval a -> Interval a +maxI (I a a') (I b b') = I (max a b) (max a' b') +{-# INLINE maxI #-} + +minI :: Ord a => Interval a -> Interval a -> Interval a +minI (I a a') (I b b') = I (min a b) (min a' b') +{-# INLINE minI #-} + +powInt :: (Ord a, Num a, RoundedRing a) => Interval a -> Int -> Interval a +powInt (I a a') n | odd n || 0 <= a = I (a^n) (a'^n) + | a' <= 0 = I ((coerce (abs a'))^n) ((coerce (abs a))^n) + | otherwise = I 0 (max ((coerce (abs a))^n) (a'^n)) +{-# SPECIALIZE powInt :: Interval Float -> Int -> Interval Float #-} +{-# SPECIALIZE powInt :: Interval Double -> Int -> Interval Double #-} + +null :: Interval a -> Bool +null _ = False + +inf :: Interval a -> Rounded 'TowardNegInf a +inf (I x _) = x + +sup :: Interval a -> Rounded 'TowardInf a +sup (I _ y) = y + +width :: (Num a, RoundedRing a) => Interval a -> Rounded 'TowardInf a +width (I x y) = y - coerce x + +hull :: RoundedRing a => Interval a -> Interval a -> Interval a +hull (I x y) (I x' y') = I (min x x') (max y y') + +{-# SPECIALIZE C.expP :: Double -> Interval Double #-} +{-# SPECIALIZE C.expI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.expm1P :: Double -> Interval Double #-} +{-# SPECIALIZE C.expm1I :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.logP :: Double -> Interval Double #-} +{-# SPECIALIZE C.logI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.log1pP :: Double -> Interval Double #-} +{-# SPECIALIZE C.log1pI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.sin_small :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.cos_small :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.sinP :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.cosP :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.sinI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.cosI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.tanI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.atan_small :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.atanP :: Double -> Interval Double #-} +{-# SPECIALIZE C.atanI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.asinP :: Double -> Interval Double #-} +{-# SPECIALIZE C.asinI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.acosP :: Double -> Interval Double #-} +{-# SPECIALIZE C.acosI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.sinhP :: Double -> Interval Double #-} +{-# SPECIALIZE C.sinhI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.coshP :: Double -> Interval Double #-} +{-# SPECIALIZE C.coshI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.tanhP :: Double -> Interval Double #-} +{-# SPECIALIZE C.tanhI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.asinhP :: Double -> Interval Double #-} +{-# SPECIALIZE C.asinhI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.acoshP :: Double -> Interval Double #-} +{-# SPECIALIZE C.acoshI :: Interval Double -> Interval Double #-} +{-# SPECIALIZE C.atanhP :: Double -> Interval Double #-} +{-# SPECIALIZE C.atanhI :: Interval Double -> Interval Double #-} + +instance (Num a, RoundedFractional a, RoundedSqrt a, Eq a, RealFloat a, RealFloatConstants a) => Floating (Interval a) where + pi = I pi_down pi_up + exp = C.expI + log = C.logI + sqrt = C.sqrtI + -- x ** y = exp (log x * y) -- default + -- logBase x y = log y / log x -- default + sin = C.sinI + cos = C.cosI + tan = C.tanI + asin = C.asinI + acos = C.acosI + atan = C.atanI + sinh = C.sinhI + cosh = C.coshI + tanh = C.tanhI + asinh = C.asinhI + acosh = C.acoshI + atanh = C.atanhI + log1p = C.log1pI + expm1 = C.expm1I + -- log1pexp x = log (1 + exp x) -- default + -- log1mexp x = log (1 - exp x) -- default + {-# SPECIALIZE instance Floating (Interval Float) #-} + {-# SPECIALIZE instance Floating (Interval Double) #-} + +instance (RealFloat a, RoundedRing a) => C.IsInterval (Interval a) where + type EndPoint (Interval a) = a + makeInterval = I + width = width + withEndPoints f (I x y) = f x y + hull = hull + intersection (I x y) (I x' y') | getRounded x'' <= getRounded y'' = I x'' y'' + | otherwise = error "empty intersection" + where x'' = max x x' + y'' = min y y' + maybeIntersection (I x y) (I x' y') | getRounded x'' <= getRounded y'' = Just (I x'' y'') + | otherwise = Nothing + where x'' = max x x' + y'' = min y y' + equalAsSet (I x y) (I x' y') = x == x' && y == y' + subset (I x y) (I x' y') = x' <= x && y <= y' + weaklyLess (I x y) (I x' y') = x <= x' && y <= y' + precedes (I _ y) (I x' _) = getRounded y <= getRounded x' + interior (I x y) (I x' y') = getRounded x' <# getRounded x && getRounded y <# getRounded y' + where s <# t = s < t || (s == t && isInfinite s) + strictLess (I x y) (I x' y') = getRounded x <# getRounded x' && getRounded y <# getRounded y' + where s <# t = s < t || (s == t && isInfinite s) + strictPrecedes (I _ y) (I x' _) = getRounded y < getRounded x' + disjoint (I x y) (I x' y') = getRounded y < getRounded x' || getRounded y' < getRounded x + {-# INLINE makeInterval #-} + {-# INLINE width #-} + {-# INLINE withEndPoints #-} + {-# INLINE hull #-} + {-# INLINE intersection #-} + {-# INLINE maybeIntersection #-} + {-# INLINE equalAsSet #-} + {-# INLINE subset #-} + {-# INLINE weaklyLess #-} + {-# INLINE precedes #-} + {-# INLINE interior #-} + {-# INLINE strictLess #-} + {-# INLINE strictPrecedes #-} + {-# INLINE disjoint #-} + +-- +-- Instance for Data.Vector.Unboxed.Unbox +-- + +newtype instance VUM.MVector s (Interval a) = MV_Interval (VUM.MVector s (a, a)) +newtype instance VU.Vector (Interval a) = V_Interval (VU.Vector (a, a)) + +intervalToPair :: Fractional a => Interval a -> (a, a) +intervalToPair (I (Rounded x) (Rounded y)) = (x, y) +{-# INLINE intervalToPair #-} + +pairToInterval :: Ord a => (a, a) -> Interval a +pairToInterval (x, y) = I (Rounded x) (Rounded y) +{-# INLINE pairToInterval #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VGM.MVector VUM.MVector (Interval a) where + basicLength (MV_Interval mv) = VGM.basicLength mv + basicUnsafeSlice i l (MV_Interval mv) = MV_Interval (VGM.basicUnsafeSlice i l mv) + basicOverlaps (MV_Interval mv) (MV_Interval mv') = VGM.basicOverlaps mv mv' + basicUnsafeNew l = MV_Interval <$> VGM.basicUnsafeNew l + basicInitialize (MV_Interval mv) = VGM.basicInitialize mv + basicUnsafeReplicate i x = MV_Interval <$> VGM.basicUnsafeReplicate i (intervalToPair x) + basicUnsafeRead (MV_Interval mv) i = pairToInterval <$> VGM.basicUnsafeRead mv i + basicUnsafeWrite (MV_Interval mv) i x = VGM.basicUnsafeWrite mv i (intervalToPair x) + basicClear (MV_Interval mv) = VGM.basicClear mv + basicSet (MV_Interval mv) x = VGM.basicSet mv (intervalToPair x) + basicUnsafeCopy (MV_Interval mv) (MV_Interval mv') = VGM.basicUnsafeCopy mv mv' + basicUnsafeMove (MV_Interval mv) (MV_Interval mv') = VGM.basicUnsafeMove mv mv' + basicUnsafeGrow (MV_Interval mv) n = MV_Interval <$> VGM.basicUnsafeGrow mv n + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeMove #-} + {-# INLINE basicUnsafeGrow #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VG.Vector VU.Vector (Interval a) where + basicUnsafeFreeze (MV_Interval mv) = V_Interval <$> VG.basicUnsafeFreeze mv + basicUnsafeThaw (V_Interval v) = MV_Interval <$> VG.basicUnsafeThaw v + basicLength (V_Interval v) = VG.basicLength v + basicUnsafeSlice i l (V_Interval v) = V_Interval (VG.basicUnsafeSlice i l v) + basicUnsafeIndexM (V_Interval v) i = pairToInterval <$> VG.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Interval mv) (V_Interval v) = VG.basicUnsafeCopy mv v + elemseq (V_Interval _) x y = x `seq` y + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE elemseq #-} + +instance (VU.Unbox a, Ord a, Fractional a) => VU.Unbox (Interval a) + +-- +-- Instances for Data.Array.Unboxed +-- + +instance (Prim a, Ord a, Fractional a) => A.MArray (A.STUArray s) (Interval a) (ST s) where + getBounds (A.STUArray l u _ _) = return (l, u) + getNumElements (A.STUArray _ _ n _) = return n + -- newArray: Use default + unsafeNewArray_ = A.newArray_ + newArray_ bounds@(l,u) = do + let n = rangeSize bounds + arr@(MutableByteArray arr_) <- newByteArray (2 * sizeOf (undefined :: a) * n) + setByteArray arr 0 (2 * n) (0 :: a) + return (A.STUArray l u n arr_) + unsafeRead (A.STUArray _ _ _ byteArr) i = do + x <- readByteArray (MutableByteArray byteArr) (2 * i) + y <- readByteArray (MutableByteArray byteArr) (2 * i + 1) + return (pairToInterval (x, y)) + unsafeWrite (A.STUArray _ _ _ byteArr) i e = do + let (x, y) = intervalToPair e + writeByteArray (MutableByteArray byteArr) (2 * i) x + writeByteArray (MutableByteArray byteArr) (2 * i + 1) y + +instance (Prim a, Ord a, Fractional a) => A.IArray A.UArray (Interval a) where + bounds (A.UArray l u _ _) = (l,u) + numElements (A.UArray _ _ n _) = n + unsafeArray bounds el = runST $ do + marr <- A.newArray_ bounds + forM_ el $ \(i,e) -> A.unsafeWrite marr i e + A.unsafeFreezeSTUArray marr + unsafeAt (A.UArray _ _ _ byteArr) i = + let x = indexByteArray (ByteArray byteArr) (2 * i) + y = indexByteArray (ByteArray byteArr) (2 * i + 1) + in pairToInterval (x, y) + -- unsafeReplace, unsafeAccum, unsafeAccumArray: Use default diff --git a/src/Numeric/Rounded/Hardware/Rounding.hs b/src/Numeric/Rounded/Hardware/Rounding.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Rounding.hs @@ -0,0 +1,8 @@ +module Numeric.Rounded.Hardware.Rounding + ( RoundingMode(..) + , oppositeRoundingMode + , Rounding + , rounding + , reifyRounding + ) where +import Numeric.Rounded.Hardware.Internal diff --git a/src/Numeric/Rounded/Hardware/Vector/Storable.hs b/src/Numeric/Rounded/Hardware/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Vector/Storable.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Numeric.Rounded.Hardware.Vector.Storable + ( -- * Conversion between @VS.Vector a@ and @VS.Vector (Rounded r a)@ + coercion + , fromVectorOfRounded + , toVectorOfRounded + , coercionM + , fromMVectorOfRounded + , toMVectorOfRounded + -- * Specialized functions + , roundedSum + , zipWith_roundedAdd + , zipWith_roundedSub + , zipWith_roundedMul + , zipWith3_roundedFusedMultiplyAdd + , zipWith_roundedDiv + , map_roundedSqrt + , sum + , zipWith_add + , zipWith_sub + , zipWith_mul + , zipWith3_fusedMultiplyAdd + , zipWith_div + , map_sqrt + ) where +import Data.Coerce +import Data.Proxy +import Data.Type.Coercion +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Foreign.Storable +import Numeric.Rounded.Hardware.Internal +import Prelude hiding (sum) +import Unsafe.Coerce + +-- +-- Conversion between 'VS.Vector a' and 'VS.Vector (Rounded r a)' +-- +-- 'VS.Vector' will be nominally roled after vector-0.13. +-- See: +-- * https://github.com/haskell/vector/issues/223 +-- * https://github.com/haskell/vector/pull/235 +-- +-- But, we know 'Storable (Rounded r a)' is the same as 'Storable a' +-- + +coercion :: Coercion (VS.Vector a) (VS.Vector (Rounded r a)) +coercion = unsafeCoerce (Coercion :: Coercion (VS.Vector a) (VS.Vector a)) + +fromVectorOfRounded :: VS.Vector (Rounded r a) -> VS.Vector a +fromVectorOfRounded = unsafeCoerce + +toVectorOfRounded :: VS.Vector a -> VS.Vector (Rounded r a) +toVectorOfRounded = unsafeCoerce + +coercionM :: Coercion (VSM.MVector s a) (VSM.MVector s (Rounded r a)) +coercionM = unsafeCoerce (Coercion :: Coercion (VSM.MVector s a) (VSM.MVector s a)) + +fromMVectorOfRounded :: VSM.MVector s (Rounded r a) -> VSM.MVector s a +fromMVectorOfRounded = unsafeCoerce + +toMVectorOfRounded :: VSM.MVector s a -> VSM.MVector s (Rounded r a) +toMVectorOfRounded = unsafeCoerce + +-- +-- Vector Operations +-- + +-- | Equivalent to 'VS.sum' +sum :: forall r a. (Rounding r, Storable a, RoundedRing_Vector VS.Vector a) => VS.Vector (Rounded r a) -> Rounded r a +sum v = coerce (roundedSum r (fromVectorOfRounded v)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE sum #-} + +-- | Equivalent to @'VS.zipWith' (+)@ +zipWith_add :: forall r a. (Rounding r, Storable a, RoundedRing_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +zipWith_add v1 v2 = toVectorOfRounded (zipWith_roundedAdd r (fromVectorOfRounded v1) (fromVectorOfRounded v2)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_add #-} + +-- | Equivalent to @'VS.zipWith' (-)@ +zipWith_sub :: forall r a. (Rounding r, Storable a, RoundedRing_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +zipWith_sub v1 v2 = toVectorOfRounded (zipWith_roundedSub r (fromVectorOfRounded v1) (fromVectorOfRounded v2)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_sub #-} + +-- | Equivalent to @'VS.zipWith' (*)@ +zipWith_mul :: forall r a. (Rounding r, Storable a, RoundedRing_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +zipWith_mul v1 v2 = toVectorOfRounded (zipWith_roundedMul r (fromVectorOfRounded v1) (fromVectorOfRounded v2)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_mul #-} + +-- | Equivalent to @'VS.zipWith3' fusedMultiplyAdd@ +zipWith3_fusedMultiplyAdd :: forall r a. (Rounding r, Storable a, RoundedRing_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +zipWith3_fusedMultiplyAdd v1 v2 v3 = toVectorOfRounded (zipWith3_roundedFusedMultiplyAdd r (fromVectorOfRounded v1) (fromVectorOfRounded v2) (fromVectorOfRounded v3)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith3_fusedMultiplyAdd #-} + +-- | Equivalent to @'VS.zipWith' (/)@ +zipWith_div :: forall r a. (Rounding r, Storable a, RoundedFractional_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +zipWith_div v1 v2 = toVectorOfRounded (zipWith_roundedDiv r (fromVectorOfRounded v1) (fromVectorOfRounded v2)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_div #-} + +-- | Equivalent to @'VS.map' sqrt@ +map_sqrt :: forall r a. (Rounding r, Storable a, RoundedSqrt_Vector VS.Vector a) => VS.Vector (Rounded r a) -> VS.Vector (Rounded r a) +map_sqrt v = toVectorOfRounded (map_roundedSqrt r (fromVectorOfRounded v)) + where r = rounding (Proxy :: Proxy r) +{-# INLINE map_sqrt #-} diff --git a/src/Numeric/Rounded/Hardware/Vector/Unboxed.hs b/src/Numeric/Rounded/Hardware/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Rounded/Hardware/Vector/Unboxed.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Numeric.Rounded.Hardware.Vector.Unboxed + ( roundedSum + , zipWith_roundedAdd + , zipWith_roundedSub + , zipWith_roundedMul + , zipWith3_roundedFusedMultiplyAdd + , zipWith_roundedDiv + , map_roundedSqrt + , sum + , zipWith_add + , zipWith_sub + , zipWith_mul + , zipWith3_fusedMultiplyAdd + , zipWith_div + , map_sqrt + ) where +import Data.Coerce +import Data.Proxy +import qualified Data.Vector.Unboxed as VU +import Numeric.Rounded.Hardware.Internal +import Prelude hiding (sum) + +-- | Equivalent to 'VU.sum' +sum :: forall r a. (Rounding r, VU.Unbox a, RoundedRing_Vector VU.Vector a) => VU.Vector (Rounded r a) -> Rounded r a +sum = coerce (roundedSum r :: VU.Vector a -> a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE sum #-} + +-- | Equivalent to @'VU.zipWith' (+)@ +zipWith_add :: forall r a. (Rounding r, VU.Unbox a, RoundedRing_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +zipWith_add = coerce (zipWith_roundedAdd r :: VU.Vector a -> VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_add #-} + +-- | Equivalent to @'VU.zipWith' (-)@ +zipWith_sub :: forall r a. (Rounding r, VU.Unbox a, RoundedRing_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +zipWith_sub = coerce (zipWith_roundedSub r :: VU.Vector a -> VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_sub #-} + +-- | Equivalent to @'VU.zipWith' (*)@ +zipWith_mul :: forall r a. (Rounding r, VU.Unbox a, RoundedRing_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +zipWith_mul = coerce (zipWith_roundedMul r :: VU.Vector a -> VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_mul #-} + +-- | Equivalent to @'VU.zipWith3' fusedMultiplyAdd@ +zipWith3_fusedMultiplyAdd :: forall r a. (Rounding r, VU.Unbox a, RoundedRing_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +zipWith3_fusedMultiplyAdd = coerce (zipWith3_roundedFusedMultiplyAdd r :: VU.Vector a -> VU.Vector a -> VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith3_fusedMultiplyAdd #-} + +-- | Equivalent to @'VU.zipWith' (/)@ +zipWith_div :: forall r a. (Rounding r, VU.Unbox a, RoundedFractional_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +zipWith_div = coerce (zipWith_roundedDiv r :: VU.Vector a -> VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE zipWith_div #-} + +-- | Equivalent to @'VU.map' sqrt@ +map_sqrt :: forall r a. (Rounding r, VU.Unbox a, RoundedSqrt_Vector VU.Vector a) => VU.Vector (Rounded r a) -> VU.Vector (Rounded r a) +map_sqrt = coerce (map_roundedSqrt r :: VU.Vector a -> VU.Vector a) + where r = rounding (Proxy :: Proxy r) +{-# INLINE map_sqrt #-} diff --git a/test/ConstantsSpec.hs b/test/ConstantsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConstantsSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +module ConstantsSpec (spec, specT) where +import Data.Proxy +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Util + +prop_maxFinite :: (RealFloat a, RealFloatConstants a) => Proxy a -> Bool +prop_maxFinite proxy = nextUp maxFinite `sameFloat` (positiveInfinity `asProxyTypeOf` proxy) + +prop_minPositive :: (RealFloat a, RealFloatConstants a) => Proxy a -> Bool +prop_minPositive proxy = nextDown minPositive `sameFloat` (0 `asProxyTypeOf` proxy) + +prop_almostExact :: RealFloat a => Proxy a -> Rounded 'TowardNegInf a -> Rounded 'TowardInf a -> Bool +prop_almostExact _proxy (Rounded x) (Rounded y) = (x `sameFloat` nextDown y) && (nextUp x `sameFloat` y) + +specT :: (RealFloat a, RealFloatConstants a) => Proxy a -> Spec +specT proxy = do + it "maxFinite" $ prop_maxFinite proxy + it "minPositive" $ prop_minPositive proxy + it "pi" $ prop_almostExact proxy pi_down pi_up + it "3*pi" $ prop_almostExact proxy three_pi_down three_pi_up + it "5*pi" $ prop_almostExact proxy five_pi_down five_pi_up + it "log(2)" $ prop_almostExact proxy log2_down log2_up + it "exp(1)" $ prop_almostExact proxy exp1_down exp1_up + it "exp(1/2)" $ prop_almostExact proxy exp1_2_down exp1_2_up + it "exp(-1/2)" $ prop_almostExact proxy expm1_2_down expm1_2_up + it "sqrt(2)" $ prop_almostExact proxy sqrt2_down sqrt2_up + it "sqrt(2)-1" $ prop_almostExact proxy sqrt2m1_down sqrt2m1_up + it "sqrt(1/2)" $ prop_almostExact proxy sqrt1_2_down sqrt1_2_up + it "3-2*sqrt(2)" $ prop_almostExact proxy three_minus_2sqrt2_down three_minus_2sqrt2_up + it "2-sqrt(2)" $ prop_almostExact proxy two_minus_sqrt2_down two_minus_sqrt2_up + +spec :: Spec +spec = do + describe "Double" $ specT (Proxy :: Proxy Double) + describe "Float" $ specT (Proxy :: Proxy Float) diff --git a/test/Float128Spec.hs b/test/Float128Spec.hs new file mode 100644 --- /dev/null +++ b/test/Float128Spec.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Float128Spec where +import qualified ConstantsSpec +import Data.Int +import Data.Proxy +import qualified FloatUtilSpec +import qualified FromIntegerSpec +import qualified FromRationalSpec +import qualified IntervalArithmeticSpec +import Numeric.Float128 (Float128) +import qualified RoundedArithmeticSpec +import qualified ShowFloatSpec +import System.Random +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util + +-- orphan instances +instance Arbitrary Float128 where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +instance Random Float128 where + randomR (lo,hi) g = let (x,g') = random g + in (lo + x * (hi - lo), g') -- TODO: avoid overflow + random g = let x :: Int64 + (x,g') = random g + in (fromIntegral x / 2^(63 :: Int), g') -- TODO: do better + +spec :: Spec +spec = do + describe "rounded arithmetic" $ RoundedArithmeticSpec.specT f128Proxy + describe "rounded arithmetic" $ RoundedArithmeticSpec.verifyImplementation f128Proxy f128Proxy + describe "interval arithmetic" $ IntervalArithmeticSpec.verifyImplementation f128Proxy + describe "fromInteger" $ FromIntegerSpec.specT f128Proxy False + describe "fromRational" $ FromRationalSpec.specT f128Proxy False + describe "showFloat" $ ShowFloatSpec.specT f128Proxy + describe "constants" $ ConstantsSpec.specT f128Proxy + prop "nextUp . nextDown == id (unless -inf)" $ forAll variousFloats (FloatUtilSpec.prop_nextUp_nextDown :: Float128 -> Property) + prop "nextDown . nextUp == id (unless inf)" $ forAll variousFloats (FloatUtilSpec.prop_nextDown_nextUp :: Float128 -> Property) + where + f128Proxy :: Proxy Float128 + f128Proxy = Proxy diff --git a/test/FloatUtilSpec.hs b/test/FloatUtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/FloatUtilSpec.hs @@ -0,0 +1,75 @@ +module FloatUtilSpec where +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util (sameFloatP, variousFloats) + +foreign import ccall unsafe "nextafter" + c_nextafter_double :: Double -> Double -> Double +foreign import ccall unsafe "nextafterf" + c_nextafter_float :: Float -> Float -> Float +foreign import ccall unsafe "fma" + c_fma_double :: Double -> Double -> Double -> Double +foreign import ccall unsafe "fmaf" + c_fma_float :: Float -> Float -> Float -> Float + +class Fractional a => CFloat a where + c_nextafter :: a -> a -> a + c_fma :: a -> a -> a -> a + +instance CFloat Double where + c_nextafter = c_nextafter_double + c_fma = c_fma_double + +instance CFloat Float where + c_nextafter = c_nextafter_float + c_fma = c_fma_float + +c_nextUp, c_nextDown, c_nextTowardZero :: (RealFloat a, CFloat a) => a -> a +c_nextUp x = c_nextafter x (1/0) +c_nextDown x = c_nextafter x (-1/0) +c_nextTowardZero x | isNegativeZero x = x + | otherwise = c_nextafter x 0 + +prop_nextUp_match :: (RealFloat a, CFloat a, Show a) => a -> Property +prop_nextUp_match x = nextUp x `sameFloatP` c_nextUp x + +prop_nextDown_match :: (RealFloat a, CFloat a, Show a) => a -> Property +prop_nextDown_match x = nextDown x `sameFloatP` c_nextDown x + +prop_nextTowardZero_match :: (RealFloat a, CFloat a, Show a) => a -> Property +prop_nextTowardZero_match x = nextTowardZero x `sameFloatP` c_nextTowardZero x + +prop_fma_match :: (RealFloat a, CFloat a, Show a) => a -> a -> a -> Property +prop_fma_match x y z = fusedMultiplyAdd x y z `sameFloatP` c_fma x y z + +isPositiveZero :: RealFloat a => a -> Bool +isPositiveZero x = x == 0 && not (isNegativeZero x) + +prop_nextUp_nextDown :: (RealFloat a, Show a) => a -> Property +prop_nextUp_nextDown x = x /= (-1/0) ==> + let x' = nextUp (nextDown x) + in x' `sameFloatP` x .||. (isPositiveZero x .&&. isNegativeZero x') + +prop_nextDown_nextUp :: (RealFloat a, Show a) => a -> Property +prop_nextDown_nextUp x = x /= (1/0) ==> + let x' = nextDown (nextUp x) + in x' `sameFloatP` x .||. (isNegativeZero x .&&. isPositiveZero x') + +spec :: Spec +spec = do + describe "Double" $ do + prop "nextUp vs C nextafter" $ forAll variousFloats (prop_nextUp_match :: Double -> Property) + prop "nextDown vs C nextafter" $ forAll variousFloats (prop_nextDown_match :: Double -> Property) + prop "nextTowardZero vs C nextafter" $ forAll variousFloats (prop_nextTowardZero_match :: Double -> Property) + prop "nextUp . nextDown == id (unless -inf)" $ forAll variousFloats (prop_nextUp_nextDown :: Double -> Property) + prop "nextDown . nextUp == id (unless inf)" $ forAll variousFloats (prop_nextDown_nextUp :: Double -> Property) + prop "fusedMultiplyAdd vs C fma" $ forAll variousFloats (prop_fma_match :: Double -> Double -> Double -> Property) + describe "Float" $ do + prop "nextUp vs C nextafter" $ forAll variousFloats (prop_nextUp_match :: Float -> Property) + prop "nextDown vs C nextafter" $ forAll variousFloats (prop_nextDown_match :: Float -> Property) + prop "nextTowardZero vs C nextafter" $ forAll variousFloats (prop_nextTowardZero_match :: Float -> Property) + prop "nextUp . nextDown == id (unless -inf)" $ forAll variousFloats (prop_nextUp_nextDown :: Float -> Property) + prop "nextDown . nextUp == id (unless inf)" $ forAll variousFloats (prop_nextDown_nextUp :: Float -> Property) + prop "fusedMultiplyAdd vs C fma" $ forAll variousFloats (prop_fma_match :: Float -> Float -> Float -> Property) diff --git a/test/FromIntegerSpec.hs b/test/FromIntegerSpec.hs new file mode 100644 --- /dev/null +++ b/test/FromIntegerSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module FromIntegerSpec where +import Control.Monad +import Data.Int +import Data.Proxy +import Data.Word +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util + +prop_fromInteger_nearest_stock :: forall a. (RealFloat a, RoundedRing a) => Proxy a -> Integer -> Property +prop_fromInteger_nearest_stock _proxy x + = (roundedFromInteger ToNearest x :: a) + `sameFloatP` (fromInteger x :: a) + +prop_roundedFromInteger_check :: forall a. (RealFloat a, RoundedRing a) => Proxy a -> RoundingMode -> Integer -> Property +prop_roundedFromInteger_check _proxy r x + = (roundedFromInteger r x :: a) + `sameFloatP` (fromInt r x :: a) + +prop_roundedFromInt64_check :: forall a. (RealFloat a, RoundedRing a) => Proxy a -> RoundingMode -> Int64 -> Property +prop_roundedFromInt64_check _proxy r x + = (roundedFromInteger r (fromIntegral x) :: a) + `sameFloatP` (fromInt r (fromIntegral x) :: a) + +prop_roundedFromWord64_check :: forall a. (RealFloat a, RoundedRing a) => Proxy a -> RoundingMode -> Word64 -> Property +prop_roundedFromWord64_check _proxy r x + = (roundedFromInteger r (fromIntegral x) :: a) + `sameFloatP` (fromInt r (fromIntegral x) :: a) + +prop_fromInt_order :: forall a. RealFloat a => Proxy a -> Integer -> Property +prop_fromInt_order _proxy x + = let ne = fromInt ToNearest x :: a + ze = fromInt TowardZero x :: a + inf = fromInt TowardInf x :: a + ninf = fromInt TowardNegInf x :: a + in ninf <= inf + .&&. (ne == ninf || ne == inf) + .&&. (if x < 0 then ze == inf else ze == ninf) + +prop_fromInt_exact :: forall a. RealFloat a => Proxy a -> Integer -> Property +prop_fromInt_exact _proxy x + = let inf = fromInt TowardInf x :: a + ninf = fromInt TowardNegInf x :: a + in if ninf == inf + then not (isInfinite inf) .&&. toRational inf === fromInteger x + else if isInfinite inf + then inf > 0 + .&&. not (isInfinite ninf) + .&&. toRational ninf =/= fromInteger x + else if isInfinite ninf + then ninf < 0 + .&&. not (isInfinite inf) + .&&. toRational inf =/= fromInteger x + else toRational inf =/= fromInteger x + .&&. toRational ninf =/= fromInteger x + +specT :: forall a. (RealFloat a, RoundedRing a) => Proxy a -> Bool -> Spec +specT proxy checkAgainstStock = do + when checkAgainstStock $ do + prop "fromInteger (nearest) coincides with stock fromInteger" $ + -- fromInteger for Double/Float do not necessarily round to nearest. + forAllShrink variousIntegers shrinkIntegral (prop_fromInteger_nearest_stock proxy) + prop "roundedFromInteger coincides with the standard implementation" $ \r -> + forAllShrink variousIntegers shrinkIntegral (prop_roundedFromInteger_check proxy r) + prop "roundedFromInteger/Int64" $ \r -> + prop_roundedFromInt64_check proxy r + prop "roundedFromInteger/Word64" $ \r -> + prop_roundedFromWord64_check proxy r + prop "order" $ + forAllShrink variousIntegers shrinkIntegral (prop_fromInt_order proxy) + prop "exactness" $ + forAllShrink variousIntegers shrinkIntegral (prop_fromInt_exact proxy) + +spec :: Spec +spec = do + describe "Double" $ specT (Proxy :: Proxy Double) False + describe "Float" $ specT (Proxy :: Proxy Float) False diff --git a/test/FromRationalSpec.hs b/test/FromRationalSpec.hs new file mode 100644 --- /dev/null +++ b/test/FromRationalSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module FromRationalSpec where +import Control.Monad +import Data.Proxy +import Data.Ratio +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util + +prop_fromRational_nearest_stock :: forall a. (RealFloat a, RoundedFractional a) => Proxy a -> Rational -> Property +prop_fromRational_nearest_stock _proxy x + = (roundedFromRational ToNearest x :: a) + `sameFloatP` (fromRational x :: a) + +prop_roundedFromRational_check :: forall a. (RealFloat a, RoundedFractional a) => Proxy a -> RoundingMode -> Rational -> Property +prop_roundedFromRational_check _proxy r x + = (fromRatio r (numerator x) (denominator x) :: a) -- the standard implementation + `sameFloatP` (roundedFromRational r x :: a) -- may be optimized + +prop_fromRatio_order :: forall a. RealFloat a => Proxy a -> Rational -> Property +prop_fromRatio_order _proxy x + = let ne = fromRatio ToNearest (numerator x) (denominator x) :: a + ze = fromRatio TowardZero (numerator x) (denominator x) :: a + inf = fromRatio TowardInf (numerator x) (denominator x) :: a + ninf = fromRatio TowardNegInf (numerator x) (denominator x) :: a + in ninf <= inf + .&&. (ne == ninf || ne == inf) + .&&. (if x < 0 then ze == inf else ze == ninf) + +prop_fromRatio_exact :: forall a. RealFloat a => Proxy a -> Rational -> Property +prop_fromRatio_exact _proxy x + = let inf = fromRatio TowardInf (numerator x) (denominator x) :: a + ninf = fromRatio TowardNegInf (numerator x) (denominator x) :: a + in if ninf == inf + then not (isInfinite inf) .&&. toRational inf === x + else if isInfinite inf + then inf > 0 + .&&. not (isInfinite ninf) + .&&. toRational ninf =/= x + else if isInfinite ninf + then ninf < 0 + .&&. not (isInfinite inf) + .&&. toRational inf =/= x + else toRational inf =/= x + .&&. toRational ninf =/= x + +specT :: forall a. (RealFloat a, RoundedFractional a) => Proxy a -> Bool -> Spec +specT proxy checkAgainstStock = do + when checkAgainstStock $ do + -- Although fromRational for Double/Float correctly round to nearest, other types may not. + prop "fromRational (nearest) coincides with stock fromRational" $ + forAllShrink variousRationals shrinkRealFrac $ prop_fromRational_nearest_stock proxy + prop "roundedFromRational coincides with the standard implementation" $ \r -> + forAllShrink variousRationals shrinkRealFrac $ prop_roundedFromRational_check proxy r + prop "order" $ + forAllShrink variousRationals shrinkRealFrac $ prop_fromRatio_order proxy + prop "exactness" $ + forAllShrink variousRationals shrinkRealFrac $ prop_fromRatio_exact proxy + +spec :: Spec +spec = do + describe "Double" $ specT (Proxy :: Proxy Double) True + describe "Float" $ specT (Proxy :: Proxy Float) True diff --git a/test/IntervalArithmeticSpec.hs b/test/IntervalArithmeticSpec.hs new file mode 100644 --- /dev/null +++ b/test/IntervalArithmeticSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module IntervalArithmeticSpec where +import Data.Proxy +import Numeric.Rounded.Hardware.Internal +import Numeric.Rounded.Hardware.Interval +import Numeric.Rounded.Hardware.Interval.Class (makeInterval, equalAsSet) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +data OrdPair a = OrdPair a a deriving (Eq, Show) + +instance (Arbitrary a, Ord a) => Arbitrary (OrdPair a) where + arbitrary = do x <- arbitrary + y <- arbitrary + return $ OrdPair (min x y) (max x y) + +verifyImplementation :: forall a. (Arbitrary a, Ord a, Show a, RoundedFractional a, RoundedSqrt a, RealFloatConstants a, RealFloat a) => Proxy a -> Spec +verifyImplementation _ = do + prop "intervalAdd" $ \(OrdPair (x :: a) y) (OrdPair x' y') -> + let iv1, iv2 :: Interval a + iv1 = makeInterval (Rounded x) (Rounded y) + makeInterval (Rounded x') (Rounded y') + iv2 = makeInterval (Rounded $ roundedAdd TowardNegInf x x') (Rounded $ roundedAdd TowardInf y y') + in iv1 `equalAsSet` iv2 + prop "intervalSub" $ \(OrdPair (x :: a) y) (OrdPair x' y') -> + let iv1, iv2 :: Interval a + iv1 = makeInterval (Rounded x) (Rounded y) - makeInterval (Rounded x') (Rounded y') + iv2 = makeInterval (Rounded $ roundedSub TowardNegInf x y') (Rounded $ roundedSub TowardInf y x') + in iv1 `equalAsSet` iv2 + prop "intervalSqrt" $ \(OrdPair (NonNegative (x :: a)) (NonNegative y)) -> + let iv1, iv2 :: Interval a + iv1 = sqrt (makeInterval (Rounded x) (Rounded y)) + iv2 = makeInterval (Rounded $ roundedSqrt TowardNegInf x) (Rounded $ roundedSqrt TowardInf y) + in iv1 `equalAsSet` iv2 + +spec :: Spec +spec = do + describe "Double" $ verifyImplementation (Proxy :: Proxy Double) + describe "Float" $ verifyImplementation (Proxy :: Proxy Float) diff --git a/test/RoundedArithmeticSpec.hs b/test/RoundedArithmeticSpec.hs new file mode 100644 --- /dev/null +++ b/test/RoundedArithmeticSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module RoundedArithmeticSpec where +import Data.Coerce +import Data.Proxy +import qualified Numeric.Rounded.Hardware.Backend.C as Backend.C +import Numeric.Rounded.Hardware.Backend.ViaRational +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util + +infix 4 ==. +(==.) :: (RealFloat a, Show a) => a -> a -> Property +(==.) = sameFloatP + +prop_roundedAdd :: (RealFloat a, Show a, RoundedRing a) => Proxy a -> a -> a -> Property +prop_roundedAdd _proxy x y = + -- Assume neither x nor y is NaN + let ne = roundedAdd ToNearest x y + ze = roundedAdd TowardZero x y + inf = roundedAdd TowardInf x y + ninf = roundedAdd TowardNegInf x y + in ne ==. x + y .&&. ninf <= inf .&&. (ne ==. ninf .||. ne ==. inf) .&&. (ze ==. ninf .||. ze ==. inf) .&&. abs ze ==. min (abs ninf) (abs inf) + +prop_roundedSub :: (RealFloat a, Show a, RoundedRing a) => Proxy a -> a -> a -> Property +prop_roundedSub _proxy x y = + -- Assume neither x nor y is NaN + let ne = roundedSub ToNearest x y + ze = roundedSub TowardZero x y + inf = roundedSub TowardInf x y + ninf = roundedSub TowardNegInf x y + in ne ==. x - y .&&. ninf <= inf .&&. (ne ==. ninf .||. ne ==. inf) .&&. (ze ==. ninf .||. ze ==. inf) .&&. abs ze ==. min (abs ninf) (abs inf) + +prop_roundedMul :: (RealFloat a, Show a, RoundedRing a) => Proxy a -> a -> a -> Property +prop_roundedMul _proxy x y = + -- Assume neither x nor y is NaN + let ne = roundedMul ToNearest x y + ze = roundedMul TowardZero x y + inf = roundedMul TowardInf x y + ninf = roundedMul TowardNegInf x y + in ne ==. x * y .&&. ninf <= inf .&&. (ne ==. ninf .||. ne ==. inf) .&&. (ze ==. ninf .||. ze ==. inf) .&&. abs ze ==. min (abs ninf) (abs inf) + +prop_roundedDiv :: (RealFloat a, Show a, RoundedFractional a) => Proxy a -> a -> NonZero a -> Property +prop_roundedDiv _proxy x (NonZero y) = + -- Assume neither x nor y is NaN + let ne = roundedDiv ToNearest x y + ze = roundedDiv TowardZero x y + inf = roundedDiv TowardInf x y + ninf = roundedDiv TowardNegInf x y + in ne ==. x / y .&&. ninf <= inf .&&. (ne ==. ninf .||. ne ==. inf) .&&. (ze ==. ninf .||. ze ==. inf) .&&. abs ze ==. min (abs ninf) (abs inf) + +prop_roundedSqrt :: (RealFloat a, Show a, RoundedSqrt a) => Proxy a -> a -> Property +prop_roundedSqrt _proxy x = + -- Assume neither x nor y is NaN + let ne = roundedSqrt ToNearest x + ze = roundedSqrt TowardZero x + inf = roundedSqrt TowardInf x + ninf = roundedSqrt TowardNegInf x + in if isNaN x || x < 0 + then isNaN ne .&&. isNaN ze .&&. isNaN inf .&&. isNaN ninf + else ne ==. sqrt x .&&. ninf <= inf .&&. (ne ==. ninf .||. ne ==. inf) .&&. (ze ==. ninf .||. ze ==. inf) .&&. abs ze ==. min (abs ninf) (abs inf) + +specT :: (RealFloat a, RoundedFractional a, RoundedSqrt a, Arbitrary a, Show a) => Proxy a -> Spec +specT proxy = do + prop "roundedAdd" $ prop_roundedAdd proxy + prop "roundedSub" $ prop_roundedSub proxy + prop "roundedMul" $ prop_roundedMul proxy + prop "roundedDiv" $ prop_roundedDiv proxy + prop "roundedSqrt" $ prop_roundedSqrt proxy + +verifyImplementation :: forall base a. (RealFloat base, RoundedFractional a, RoundedSqrt a, Arbitrary base, Show base, RealFloatConstants base, Coercible a base) => Proxy base -> Proxy a -> Spec +verifyImplementation _ _ = do + let unVR (ViaRational x) = x + c :: base -> a + c x = coerce x + prop "roundedAdd" $ \r x y -> unVR (roundedAdd r (ViaRational x) (ViaRational y)) ==. coerce (roundedAdd r (c x) (c y)) + prop "roundedSub" $ \r x y -> unVR (roundedSub r (ViaRational x) (ViaRational y)) ==. coerce (roundedSub r (c x) (c y)) + prop "roundedMul" $ \r x y -> unVR (roundedMul r (ViaRational x) (ViaRational y)) ==. coerce (roundedMul r (c x) (c y)) + prop "roundedDiv" $ \r x y -> unVR (roundedDiv r (ViaRational x) (ViaRational y)) ==. coerce (roundedDiv r (c x) (c y)) + prop "roundedSqrt" $ \r x -> unVR (roundedSqrt r (ViaRational x)) ==. coerce (roundedSqrt r (c x)) + +spec :: Spec +spec = do + describe "Double" $ specT (Proxy :: Proxy Double) + describe "Float" $ specT (Proxy :: Proxy Float) + describe "Double default" $ verifyImplementation (Proxy :: Proxy Double) (Proxy :: Proxy Double) + describe "Float default" $ verifyImplementation (Proxy :: Proxy Float) (Proxy :: Proxy Float) + + -- TODO: Disable when `pure-hs` is on + describe "Double C" $ verifyImplementation (Proxy :: Proxy Double) (Proxy :: Proxy Backend.C.CDouble) + describe "Float C" $ verifyImplementation (Proxy :: Proxy Float) (Proxy :: Proxy Backend.C.CFloat) diff --git a/test/ShowFloatSpec.hs b/test/ShowFloatSpec.hs new file mode 100644 --- /dev/null +++ b/test/ShowFloatSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module ShowFloatSpec where +import Data.Int +import Data.Proxy +import Numeric +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util () + +prop_showEFloat_nearest :: forall a. RealFloat a => Proxy a -> Int -> Int32 -> Property +prop_showEFloat_nearest _proxy prec x = showEFloat mprec x' "" === showEFloatRn ToNearest mprec x' "" + where mprec = Just prec + x' = fromIntegral x / 64 :: a + +prop_showFFloat_nearest :: forall a. RealFloat a => Proxy a -> Int -> Int32 -> Property +prop_showFFloat_nearest _proxy prec x = showFFloat mprec x' "" === showFFloatRn ToNearest mprec x' "" + where mprec = Just prec + x' = fromIntegral x / 64 :: a + +prop_showGFloat_nearest :: forall a. RealFloat a => Proxy a -> Int -> Int32 -> Property +prop_showGFloat_nearest _proxy prec x = showGFloat mprec x' "" === showGFloatRn ToNearest mprec x' "" + where mprec = Just prec + x' = fromIntegral x / 64 :: a + +prop_showEFloat :: forall a. RealFloat a => Proxy a -> Maybe Int -> a -> Property +prop_showEFloat _proxy mprec x = + let rn = showEFloatRn ToNearest mprec x "" + ru = showEFloatRn TowardInf mprec x "" + rd = showEFloatRn TowardNegInf mprec x "" + rz = showEFloatRn TowardZero mprec x "" + in rn === ru .||. rn === rd .||. rz === (if x > 0 then rd else ru) + +prop_showFFloat :: forall a. RealFloat a => Proxy a -> Maybe Int -> a -> Property +prop_showFFloat _proxy mprec x = + let rn = showFFloatRn ToNearest mprec x "" + ru = showFFloatRn TowardInf mprec x "" + rd = showFFloatRn TowardNegInf mprec x "" + rz = showFFloatRn TowardZero mprec x "" + in rn === ru .||. rn === rd .||. rz === (if x > 0 then rd else ru) + +prop_showGFloat :: forall a. RealFloat a => Proxy a -> Maybe Int -> a -> Property +prop_showGFloat _proxy mprec x = + let rn = showGFloatRn ToNearest mprec x "" + ru = showGFloatRn TowardInf mprec x "" + rd = showGFloatRn TowardNegInf mprec x "" + rz = showGFloatRn TowardZero mprec x "" + in rn === ru .||. rn === rd .||. rz === (if x > 0 then rd else ru) + +testAgainstNumeric :: forall a. RealFloat a => Proxy a -> Spec +testAgainstNumeric proxy = do + describe "showFloat" $ do + prop "showEFloat (nearest)" $ prop_showEFloat_nearest proxy + prop "showFFloat (nearest)" $ prop_showFFloat_nearest proxy + prop "showGFloat (nearest)" $ prop_showGFloat_nearest proxy + prop "showEFloat/Int32" $ \mprec (x :: Int32) -> + showEFloat mprec (fromIntegral x :: a) "" === showEFloatRn ToNearest mprec (fromIntegral x :: a) "" + prop "showFFloat/Int32" $ \mprec (x :: Int32) -> + showFFloat mprec (fromIntegral x :: a) "" === showFFloatRn ToNearest mprec (fromIntegral x :: a) "" + prop "showGFloat/Int32" $ \mprec (x :: Int32) -> + showGFloat mprec (fromIntegral x :: a) "" === showGFloatRn ToNearest mprec (fromIntegral x :: a) "" + +specT :: forall a. (RealFloat a, Arbitrary a, Show a) => Proxy a -> Spec +specT proxy = do + prop "showEFloat" $ prop_showEFloat proxy + prop "showFFloat" $ prop_showFFloat proxy + prop "showGFloat" $ prop_showGFloat proxy + + -- 0.5 should be exactly representable in the type... + prop "showFFloatRn Nothing 0.5" $ \r -> showFFloatRn r Nothing (0.5 :: a) "" === "0.5" + prop "showFFloatRn (Just 0) 0.5" $ \r -> showFFloatRn r (Just 0) (0.5 :: a) "" === (if r == TowardInf then "1" else "0") + prop "showFFloatRn (Just 3) 0.5" $ \r -> showFFloatRn r (Just 3) (0.5 :: a) "" === "0.500" + prop "showGFloatRn Nothing 0.5" $ \r -> showGFloatRn r Nothing (0.5 :: a) "" === "0.5" + prop "showGFloatRn (Just 0) 0.5" $ \r -> showGFloatRn r (Just 0) (0.5 :: a) "" === (if r == TowardInf then "1" else "0") + prop "showGFloatRn (Just 3) 0.5" $ \r -> showGFloatRn r (Just 3) (0.5 :: a) "" === "0.500" + prop "showEFloatRn Nothing 0.5" $ \r -> showEFloatRn r Nothing (0.5 :: a) "" === "5.0e-1" + prop "showEFloatRn (Just 0) 0.5" $ \r -> showEFloatRn r (Just 0) (0.5 :: a) "" === "5e-1" + prop "showEFloatRn (Just 3) 0.5" $ \r -> showEFloatRn r (Just 3) (0.5 :: a) "" === "5.000e-1" + +spec :: Spec +spec = do + describe "Double" $ testAgainstNumeric (Proxy :: Proxy Double) + -- The functions in Numeric yields a rounded value: + -- >>> showFFloat Nothing (137846.59375 :: Float) "" + -- "137846.6" + -- So comparing them + -- describe "Float" $ testAgainstNumeric (Proxy :: Proxy Float) + describe "Double" $ specT (Proxy :: Proxy Double) + describe "Float" $ specT (Proxy :: Proxy Float) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +import qualified ConstantsSpec +import Data.Proxy +import qualified FromIntegerSpec +import qualified FromRationalSpec +import qualified IntervalArithmeticSpec +import Numeric.Rounded.Hardware.Backend (backendName) +import qualified RoundedArithmeticSpec +import qualified ShowFloatSpec +import qualified FloatUtilSpec +import Test.Hspec +import qualified VectorSpec +#ifdef TEST_X87_LONG_DOUBLE +import Numeric.LongDouble (LongDouble) +import qualified X87LongDoubleSpec +#endif +#ifdef TEST_FLOAT128 +import Numeric.Float128 (Float128) +import qualified Float128Spec +#endif + +printBackends :: IO () +printBackends = do + putStrLn $ "Backend for Double: " ++ backendName (Proxy :: Proxy Double) + putStrLn $ "Backend for Float: " ++ backendName (Proxy :: Proxy Float) +#ifdef TEST_X87_LONG_DOUBLE + putStrLn $ "Backend for LongDouble: " ++ backendName (Proxy :: Proxy LongDouble) +#endif +#ifdef TEST_FLOAT128 + putStrLn $ "Backend for Float128: " ++ backendName (Proxy :: Proxy Float128) +#endif + +main :: IO () +main = do + printBackends + hspec $ do + describe "fromInteger" FromIntegerSpec.spec + describe "fromRational" FromRationalSpec.spec + describe "showFloat" ShowFloatSpec.spec + describe "rounded arithmetic" RoundedArithmeticSpec.spec + describe "interval arithmetic" IntervalArithmeticSpec.spec + describe "FloatUtil" FloatUtilSpec.spec + describe "Vector" VectorSpec.spec + describe "Constants" ConstantsSpec.spec +#ifdef TEST_X87_LONG_DOUBLE + describe "x87 long double" X87LongDoubleSpec.spec +#endif +#ifdef TEST_FLOAT128 + describe "Float128" Float128Spec.spec +#endif diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-type-defaults #-} +module Util where +import Control.Applicative +import Data.Ratio +import Numeric +import Numeric.Rounded.Hardware.Internal +import System.Random +import Test.QuickCheck + +newtype ShowHexFloat a = ShowHexFloat a deriving (Eq,Ord) + +instance RealFloat a => Show (ShowHexFloat a) where + showsPrec _prec (ShowHexFloat x) = showHFloat x + +instance Arbitrary RoundingMode where + arbitrary = elements [ToNearest, TowardNegInf, TowardInf, TowardZero] + shrink ToNearest = [] + shrink TowardInf = [ToNearest] + shrink TowardNegInf = [ToNearest, TowardInf] + shrink TowardZero = [ToNearest, TowardInf, TowardNegInf] + +-- | Compares two floating point values. +-- +-- Unlike @(==)@, @+0@ and @-0@ are considered distinct and NaNs are equal. +-- +-- >>> sameFloat 0 (-0 :: Double) +-- False +-- >>> sameFloat (0/0) (0/0 :: Double) +-- True +sameFloat :: RealFloat a => a -> a -> Bool +sameFloat x y | isNaN x && isNaN y = True + | x == 0 && y == 0 = isNegativeZero x == isNegativeZero y + | otherwise = x == y + +sameFloatP :: (RealFloat a) => a -> a -> Property +sameFloatP x y = counterexample (showHFloat x . showString (interpret res) . showHFloat y $ "") res + where + res = sameFloat x y + interpret True = " === " + interpret False = " =/= " + +infix 4 `sameFloat`, `sameFloatP` + +variousFloats :: forall a. (RealFloat a, Arbitrary a, Random a, RealFloatConstants a) => Gen a +variousFloats = frequency + [ (10, arbitrary) + , (10, choose (-1, 1)) + , (10, (* encodeFloat 1 expMin) <$> choose (-1, 1) ) -- subnormal or very small normal + , (10, (* encodeFloat 1 (expMax-1)) <$> choose (-2, 2) ) -- infinity or very large normal + , (1, pure 0) -- positive zero + , (1, pure (-0)) -- negative zero + , (1, pure (1/0)) -- positive infinity + , (1, pure (-1/0)) -- negative infinity + , (1, pure (0/0)) -- NaN + , (1, pure maxFinite) -- max finite + , (1, pure (-maxFinite)) -- min negative + , (1, pure minPositive) -- min positive + , (1, pure (-minPositive)) -- max negative + ] + where (expMin,expMax) = floatRange (undefined :: a) + +variousIntegers :: Gen Integer +variousIntegers = frequency + [ (10, arbitrary) + , (10, elements [id,negate] <*> choose (2^52, 2^54)) + , (10, elements [id,negate] <*> choose (2^62, 2^64)) + , (10, elements [id,negate] <*> choose (2^100, 2^101)) + , (10, elements [id,negate] <*> choose (2^1020, 2^1030)) + , (5, elements [id,negate] <*> choose (2^1070, 2^1075)) + , (5, elements [id,negate] <*> choose (2^16382, 2^16384)) + , (3, elements [id,negate] <*> choose (2^16440, 2^16445)) + ] + +variousRationals :: Gen Rational +variousRationals = liftA2 (%) variousIntegers (variousIntegers `suchThat` (/= 0)) diff --git a/test/VectorSpec.hs b/test/VectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/VectorSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +module VectorSpec where +import Data.Proxy +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Numeric (showHFloat) +import Numeric.Rounded.Hardware.Internal +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Text.Show (showListWith) +import Util + +infix 4 ==^ +(==^) :: (VG.Vector vector a, RealFloat a, Show a) => vector a -> vector a -> Property +(==^) v1 v2 = counterexample (showListWith showHFloat (VG.toList v1) . showString (interpret res) . showListWith showHFloat (VG.toList v2) $ "") res + where + res = VG.eqBy sameFloat v1 v2 + interpret True = " === " + interpret False = " =/= " + +arbitraryVector :: (Arbitrary a, VG.Vector vector a) => Gen (vector a) +arbitraryVector = VG.fromList <$> arbitrary + +prop_roundedSum :: (RealFloat a, Show a, RoundedRing_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> Property +prop_roundedSum _proxy r v = VG.foldl' (roundedAdd r) 0 v `sameFloatP` roundedSum r v + +prop_roundedAdd :: (RealFloat a, Show a, RoundedRing_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> vector a -> Property +prop_roundedAdd _proxy r v1 v2 = VG.zipWith (roundedAdd r) v1 v2 ==^ zipWith_roundedAdd r v1 v2 + +prop_roundedSub :: (RealFloat a, Show a, RoundedRing_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> vector a -> Property +prop_roundedSub _proxy r v1 v2 = VG.zipWith (roundedSub r) v1 v2 ==^ zipWith_roundedSub r v1 v2 + +prop_roundedMul :: (RealFloat a, Show a, RoundedRing_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> vector a -> Property +prop_roundedMul _proxy r v1 v2 = VG.zipWith (roundedMul r) v1 v2 ==^ zipWith_roundedMul r v1 v2 + +prop_roundedFMA :: (RealFloat a, Show a, RoundedRing_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> vector a -> vector a -> Property +prop_roundedFMA _proxy r v1 v2 v3 = VG.zipWith3 (roundedFusedMultiplyAdd r) v1 v2 v3 ==^ zipWith3_roundedFusedMultiplyAdd r v1 v2 v3 + +prop_roundedDiv :: (RealFloat a, Show a, RoundedFractional_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> vector a -> Property +prop_roundedDiv _proxy r v1 v2 = VG.zipWith (roundedDiv r) v1 v2 ==^ zipWith_roundedDiv r v1 v2 + +prop_roundedSqrt :: (RealFloat a, Show a, RoundedSqrt_Vector vector a, VG.Vector vector a) => Proxy (vector a) -> RoundingMode -> vector a -> Property +prop_roundedSqrt _proxy r v = VG.map (roundedSqrt r) v ==^ map_roundedSqrt r v + +specT :: (RealFloat a, Arbitrary a, Show a, Show (vector a), VG.Vector vector a, RoundedFractional_Vector vector a, RoundedSqrt_Vector vector a) => Proxy (vector a) -> Spec +specT proxy = do + prop "roundedSum" $ forAll arbitraryVector $ \v r -> prop_roundedSum proxy r v + prop "roundedAdd" $ forAll arbitraryVector $ \v1 -> forAll arbitraryVector $ \v2 r -> prop_roundedAdd proxy r v1 v2 + prop "roundedSub" $ forAll arbitraryVector $ \v1 -> forAll arbitraryVector $ \v2 r -> prop_roundedSub proxy r v1 v2 + prop "roundedMul" $ forAll arbitraryVector $ \v1 -> forAll arbitraryVector $ \v2 r -> prop_roundedMul proxy r v1 v2 + prop "roundedFMA" $ forAll arbitraryVector $ \v1 -> forAll arbitraryVector $ \v2 -> forAll arbitraryVector $ \v3 r -> prop_roundedFMA proxy r v1 v2 v3 + prop "roundedDiv" $ forAll arbitraryVector $ \v1 -> forAll arbitraryVector $ \v2 r -> prop_roundedDiv proxy r v1 v2 + prop "roundedSqrt" $ forAll arbitraryVector $ \v r -> prop_roundedSqrt proxy r v + +spec :: Spec +spec = do + describe "Storable Double" $ specT (Proxy :: Proxy (VS.Vector Double)) + describe "Storable Float" $ specT (Proxy :: Proxy (VS.Vector Float)) + describe "Unboxed Double" $ specT (Proxy :: Proxy (VU.Vector Double)) + describe "Unboxed Float" $ specT (Proxy :: Proxy (VU.Vector Float)) diff --git a/test/X87LongDoubleSpec.hs b/test/X87LongDoubleSpec.hs new file mode 100644 --- /dev/null +++ b/test/X87LongDoubleSpec.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module X87LongDoubleSpec where +import qualified ConstantsSpec +import Data.Int +import Data.Proxy +import qualified FloatUtilSpec +import qualified FromIntegerSpec +import qualified FromRationalSpec +import qualified IntervalArithmeticSpec +import Numeric.LongDouble (LongDouble) +import qualified RoundedArithmeticSpec +import qualified ShowFloatSpec +import System.Random +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Util + +-- orphan instances +instance Arbitrary LongDouble where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +instance Random LongDouble where + randomR (lo,hi) g = let (x,g') = random g + in (lo + x * (hi - lo), g') -- TODO: avoid overflow + random g = let x :: Int64 + (x,g') = random g + in (fromIntegral x / 2^(63 :: Int), g') -- TODO: do better + +spec :: Spec +spec = do + describe "rounded arithmetic" $ RoundedArithmeticSpec.specT ldProxy + describe "rounded arithmetic" $ RoundedArithmeticSpec.verifyImplementation ldProxy ldProxy + describe "interval arithmetic" $ IntervalArithmeticSpec.verifyImplementation ldProxy + describe "fromInteger" $ FromIntegerSpec.specT ldProxy False + describe "fromRational" $ FromRationalSpec.specT ldProxy False + describe "showFloat" $ ShowFloatSpec.specT ldProxy + describe "constants" $ ConstantsSpec.specT ldProxy + prop "nextUp . nextDown == id (unless -inf)" $ forAll variousFloats (FloatUtilSpec.prop_nextUp_nextDown :: LongDouble -> Property) + prop "nextDown . nextUp == id (unless inf)" $ forAll variousFloats (FloatUtilSpec.prop_nextDown_nextUp :: LongDouble -> Property) + where + ldProxy :: Proxy LongDouble + ldProxy = Proxy