packages feed

rounded-hw (empty) → 0.1.0.0

raw patch · 55 files changed

+9060/−0 lines, 55 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: QuickCheck, array, base, deepseq, doctest, float128, gauge, hspec, integer-logarithms, long-double, primitive, random, rounded-hw, tagged, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for rounded-hw++## 0.1.0.0 (2020-06-23)++* Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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"+```
+ Setup.hs view
@@ -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) }
+ benchmark/Benchmark.hs view
@@ -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+           ]+      ]+    ]
+ benchmark/Conversion.hs view
@@ -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+       ]+    ]
+ benchmark/IGA.hs view
@@ -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))+       ]+  ]
+ cbits/interval-prim-x86_64-avx512.S view
@@ -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)
+ cbits/interval-prim-x86_64-sse2.S view
@@ -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)
+ cbits/interval-prim-x86_64.S view
@@ -0,0 +1,5 @@+#ifdef __AVX512F__+#include "interval-prim-x86_64-avx512.S"+#else+#include "interval-prim-x86_64-sse2.S"+#endif
+ cbits/rounded-avx512.inl view
@@ -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();+    }+}
+ cbits/rounded-common.inl view
@@ -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);+}
+ cbits/rounded-float128.c view
@@ -0,0 +1,86 @@+#define __STDC_WANT_IEC_60559_TYPES_EXT__+#include <math.h> // sqrtf128, fmaf128+#include <stdint.h>+#include <fenv.h>+#include <HsFFI.h>++#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";+}
+ cbits/rounded-x87longdouble.c view
@@ -0,0 +1,158 @@+#include <math.h>+#include <fenv.h>+#include <assert.h>+#include <stdint.h>+#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+}
+ cbits/rounded.c view
@@ -0,0 +1,195 @@+#include <stdlib.h>+#include <math.h>+#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 <x86intrin.h>++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 <x86intrin.h>++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 <fenv.h>++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;+}
+ doctests.hs view
@@ -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"+               ]
+ rounded-hw.cabal view
@@ -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 <https://github.com/minoki/rounded-hw#readme>+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
+ src/FFIWrapper/Double.hs view
@@ -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 #-}
+ src/FFIWrapper/Float.hs view
@@ -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 #-}
+ src/Numeric/Rounded/Hardware.hs view
@@ -0,0 +1,10 @@+module Numeric.Rounded.Hardware+  ( Rounded(..)+  , RoundingMode(..)+  , Rounding+  , RoundedRing+  , RoundedFractional+  , RoundedSqrt+  )+where+import           Numeric.Rounded.Hardware.Internal
+ src/Numeric/Rounded/Hardware/Backend.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Backend/C.hs view
@@ -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
+ src/Numeric/Rounded/Hardware/Backend/Default.hs view
@@ -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+  #-}
+ src/Numeric/Rounded/Hardware/Backend/FastFFI.hs view
@@ -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
+ src/Numeric/Rounded/Hardware/Backend/Float128.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Backend/ViaRational.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Backend/X87LongDouble.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Class.hs view
@@ -0,0 +1,9 @@+module Numeric.Rounded.Hardware.Class+  ( RoundedRing(..)+  , RoundedFractional(..)+  , RoundedSqrt(..)+  , RoundedRing_Vector(..)+  , RoundedFractional_Vector(..)+  , RoundedSqrt_Vector(..)+  ) where+import           Numeric.Rounded.Hardware.Internal
+ src/Numeric/Rounded/Hardware/Internal.hs view
@@ -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
+ src/Numeric/Rounded/Hardware/Internal/Class.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Internal/Constants.hs view
@@ -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 #-}
+ src/Numeric/Rounded/Hardware/Internal/Conversion.hs view
@@ -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 #-}
+ src/Numeric/Rounded/Hardware/Internal/FloatUtil.hs view
@@ -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"
+ src/Numeric/Rounded/Hardware/Internal/RoundedResult.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Internal/Rounding.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Internal/Show.hs view
@@ -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.<acc>)*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.<acc>)*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+-}
+ src/Numeric/Rounded/Hardware/Interval.hs view
@@ -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
+ src/Numeric/Rounded/Hardware/Interval/Class.hs view
@@ -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)
+ src/Numeric/Rounded/Hardware/Interval/ElementaryFunctions.hs view
@@ -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 #-}
+ src/Numeric/Rounded/Hardware/Interval/NonEmpty.hs view
@@ -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
+ src/Numeric/Rounded/Hardware/Rounding.hs view
@@ -0,0 +1,8 @@+module Numeric.Rounded.Hardware.Rounding+  ( RoundingMode(..)+  , oppositeRoundingMode+  , Rounding+  , rounding+  , reifyRounding+  ) where+import Numeric.Rounded.Hardware.Internal
+ src/Numeric/Rounded/Hardware/Vector/Storable.hs view
@@ -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 #-}
+ src/Numeric/Rounded/Hardware/Vector/Unboxed.hs view
@@ -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 #-}
+ test/ConstantsSpec.hs view
@@ -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)
+ test/Float128Spec.hs view
@@ -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
+ test/FloatUtilSpec.hs view
@@ -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)
+ test/FromIntegerSpec.hs view
@@ -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
+ test/FromRationalSpec.hs view
@@ -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
+ test/IntervalArithmeticSpec.hs view
@@ -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)
+ test/RoundedArithmeticSpec.hs view
@@ -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)
+ test/ShowFloatSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -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
+ test/Util.hs view
@@ -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))
+ test/VectorSpec.hs view
@@ -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))
+ test/X87LongDoubleSpec.hs view
@@ -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