From 651b781da2ceb19927a370df0d5398e0ccba9f92 Mon Sep 17 00:00:00 2001 From: Nick Bowler Date: Wed, 27 Jan 2010 19:10:44 -0500 Subject: [PATCH] floating: Add initial support for floating point exceptions. --- Data/Floating/Environment.hs | 69 +++++++++++++++++++++++++++++++++++++++----- altfloat.cabal | 3 ++ cfloat.c | 27 +++++++++++++++++ cfloat.h | 3 ++ configure.ac | 12 +++++++- 5 files changed, 105 insertions(+), 9 deletions(-) diff --git a/Data/Floating/Environment.hs b/Data/Floating/Environment.hs index dd103b5..bfdf945 100644 --- a/Data/Floating/Environment.hs +++ b/Data/Floating/Environment.hs @@ -25,18 +25,28 @@ -- FEnv instances the numeric classes, so it should be possible to use -- natural syntax. Note that the operations done on FEnv are stored so that -- they can be performed later, thus one should be take care not to construct --- huge thunks when using this interface. Floating point exceptions are not --- handled yet, so anything in this documentation which refers to \"the --- floating point environment\" actually means \"the current rounding mode\". +-- huge thunks when using this interface. -- -- Multi-threaded programs are almost certainly /not/ supported at this time. -{-# LANGUAGE ForeignFunctionInterface, ExistentialQuantification #-} +{-# LANGUAGE CPP, ForeignFunctionInterface, ExistentialQuantification #-} +{-# OPTIONS_GHC -I. #-} module Data.Floating.Environment ( - RoundingMode(..), FEnv, + -- * Data types + RoundingMode(..), FloatException(..), FEnvState, FEnv, + + -- * Safe access to the floating point environment fenvEval, withRoundingMode, fenvTrace, + + -- * Direct access to the floating point environment + -- | Special care must be taken when using these functions. Modifying the + -- floating point environment will affect all floating point computations + -- that have not yet been evaluated: this breaks referential transparency. + unsafeSaveEnvironment, unsafeRestoreEnvironment, unsafeSetRoundingMode, getRoundingMode ) where +#include + import Prelude hiding (Float, Double, Floating(..), RealFloat(..)) import Data.Floating.Classes @@ -48,14 +58,39 @@ import System.IO.Unsafe import Debug.Trace import Foreign.C +import Foreign foreign import ccall unsafe "set_roundmode" set_roundmode :: CInt -> IO CInt foreign import ccall unsafe "get_roundmode" get_roundmode :: IO CInt +foreign import ccall unsafe "fegetenv" + c_fegetenv :: Ptr FEnvState -> IO CInt +foreign import ccall unsafe "feholdexcept" + c_feholdexcept :: Ptr FEnvState -> IO CInt +foreign import ccall unsafe "fenv_restore" + fenv_restore :: Ptr FEnvState -> Ptr CUInt -> IO CInt + data RoundingMode = ToNearest | Upward | Downward | TowardZero deriving (Show, Read, Enum, Bounded) +data FloatException = DivByZero | Inexact | Invalid | Overflow | Underflow + deriving (Show, Read, Enum, Bounded) + +-- | Opaque type which stores the complete floating point environment. It +-- corresponds to the C type @fenv_t@. +newtype FEnvState = FEnvState (ForeignPtr FEnvState) + +instance Storable FEnvState where + sizeOf = const SIZEOF_FENV_T + alignment = const ALIGNOF_FENV_T + + peek ptr = do + fp <- mallocForeignPtrBytes SIZEOF_FENV_T + withForeignPtr fp (\p -> copyBytes p ptr SIZEOF_FENV_T) + return (FEnvState fp) + poke ptr (FEnvState fp) = do + withForeignPtr fp (\p -> copyBytes ptr p SIZEOF_FENV_T) -- | Container for computations which will be run in a modified floating point -- environment. The FEnv container records all operations for later evaluation @@ -139,14 +174,32 @@ instance RealFloat a => RealFloat (FEnv a) where classify = error "classify is not supported on FEnv." fquotRem = error "fquotRem is not supported on FEnv." --- | Sets the floating point rounding mode. This function is considered unsafe --- because it affects unevaluated thunks, breaking referential transparency. +-- | Saves the current floating point environment and, optionally, clears all +-- floating point exception flags and sets non-stop (continue on exceptions) +-- mode. +unsafeSaveEnvironment :: Bool -> IO FEnvState +unsafeSaveEnvironment reset = alloca $ \env -> do + rc <- saveEnv env + unless (rc == 0) $ fail "Error saving floating point environment." + peek env + where + saveEnv = if reset then c_feholdexcept else c_fegetenv + +-- | Restores a previously-saved floating point environment and returns the +-- list of floating point exceptions that occurred prior to restoring the +-- environment. +unsafeRestoreEnvironment :: FEnvState -> IO [FloatException] +unsafeRestoreEnvironment (FEnvState fp) = alloca $ \pe -> do + rc <- withForeignPtr fp (flip fenv_restore pe) + unless (rc == 0) $ fail "Error restoring floating point environment." + rawExcepts <- peek pe + return $! filter (testBit rawExcepts . fromEnum) [minBound..maxBound] + unsafeSetRoundingMode :: RoundingMode -> IO () unsafeSetRoundingMode mode = do rc <- set_roundmode (fromIntegral (fromEnum mode)) unless (rc == 0) $ fail "Error setting rounding mode" --- | Gets the current floating point rounding mode. getRoundingMode :: IO RoundingMode getRoundingMode = do rc <- get_roundmode diff --git a/altfloat.cabal b/altfloat.cabal index bb83771..5d25634 100644 --- a/altfloat.cabal +++ b/altfloat.cabal @@ -10,7 +10,9 @@ Stability: experimental Category: Numerical Build-Type: Simple Extra-Source-Files: configure.ac, configure, altfloat.buildinfo.in, cfloat.h + config.h.in Extra-Tmp-Files: altfloat.buildinfo, config.status config.log, config.cache + config.h Synopsis: Alternative floating point support for GHC. Description: A replacement for the standard Haskell floating point types and supporting @@ -67,6 +69,7 @@ Library else Build-Depends: integer + Include-Dirs: . C-Sources: cfloat.c Exposed-Modules: Data.Floating.CMath, diff --git a/cfloat.c b/cfloat.c index 6fe26d9..cbbd729 100644 --- a/cfloat.c +++ b/cfloat.c @@ -145,3 +145,30 @@ int get_roundmode(void) return -1; } } + +int fenv_restore(fenv_t *env, unsigned *excepts) +{ + int raw_excepts = fetestexcept(-1); + + if (excepts) { + *excepts = 0; + +#ifdef FE_DIVBYZERO + if (raw_excepts & FE_DIVBYZERO) *excepts |= 0x01; +#endif +#ifdef FE_INEXACT + if (raw_excepts & FE_INEXACT) *excepts |= 0x02; +#endif +#ifdef FE_INVALID + if (raw_excepts & FE_INVALID) *excepts |= 0x04; +#endif +#ifdef FE_OVERFLOW + if (raw_excepts & FE_OVERFLOW) *excepts |= 0x08; +#endif +#ifdef FE_UNDERFLOW + if (raw_excepts & FE_UNDERFLOW) *excepts |= 0x10; +#endif + } + + return fesetenv(env); +} diff --git a/cfloat.h b/cfloat.h index 6f108f3..64ee59b 100644 --- a/cfloat.h +++ b/cfloat.h @@ -1,6 +1,8 @@ #ifndef CFLOAT_H_ #define CFLOAT_H_ +#include + int double_format(char *buf, char spec, int precision, double val); double double_signum(double val); float float_signum(float val); @@ -11,5 +13,6 @@ int float_compare(float a, float b); int set_roundmode(int mode); int get_roundmode(void); +int fenv_restore(fenv_t *env, unsigned *excepts); #endif diff --git a/configure.ac b/configure.ac index 61012c4..219e648 100644 --- a/configure.ac +++ b/configure.ac @@ -5,8 +5,9 @@ dnl notice and this notice are preserved. This file is offered as-is, dnl without any warranty. AC_PREREQ(2.62) -AC_INIT([altfloat],[0.1],[nbowler@draconx.ca]) +AC_INIT([altfloat],[0.2],[nbowler@draconx.ca]) AC_CONFIG_SRCDIR([altfloat.cabal]) +AC_CONFIG_HEADER([config.h]) dnl We don't actually care, but this shuts up the warning. AC_ARG_WITH([compiler], [AS_HELP_STRING([--with-compiler], @@ -18,6 +19,15 @@ dnl Cabal won't let us specify the C compiler, so we need this hack. CC_OPTS=`echo $CC | sed 's/@<:@^@<:@:space:@:>@@:>@*//'` AC_SUBST([CC_OPTS]) +dnl We need to know the size and alignment of fenv_t in order to allocate it +dnl in Haskell code. +m4_define([FENV_HEADERS], [dnl +#include +]) + +AC_CHECK_SIZEOF([fenv_t], [], [FENV_HEADERS]) +AC_CHECK_ALIGNOF([fenv_t], [FENV_HEADERS]) + AC_CONFIG_FILES([ altfloat.buildinfo ]) -- 2.11.4.GIT