2 - Copyright (C) 2010 Nick Bowler.
4 - License BSD2: 2-clause BSD license. See LICENSE for full terms.
5 - This is free software: you are free to change and redistribute it.
6 - There is NO WARRANTY, to the extent permitted by law.
9 -- | Access to the floating point environment. Performing this access within
10 -- a Haskell program turns out to be extremely problematic, because floating
11 -- point operations are secretly impure. For example, the innocent-looking
14 -- @ (+) :: Double -> Double -> Double@
16 -- potentially both depends on and modifies the global floating point
19 -- This module avoids the referential transparency problems that occur as a
20 -- result of accessing the floating point environment by restricting when
21 -- computations which access it are evaluated. There is some minor discipline
22 -- required of the programmer: she must arrange her code so that pure floating
23 -- point expressions are not forced during a call to 'fenvEval'.
24 -- See @fenv-impure.hs@ in the @examples/@ directory of the altfloat
25 -- distribution for why this discipline is necessary.
27 -- FEnv instances the numeric classes, so it should be possible to use
28 -- natural syntax. Note that the operations done on FEnv are stored so that
29 -- they can be performed later, thus one should be take care not to construct
30 -- huge thunks when using this interface.
32 -- This interface has not been tested in multi-threaded programs. It might
33 -- work: more info is needed about GHC's threading support.
34 {-# LANGUAGE CPP, ForeignFunctionInterface, ExistentialQuantification #-}
35 {-# OPTIONS_GHC -I. #-}
36 module Data
.Floating
.Environment
(
37 module Control
.Applicative
,
40 RoundingMode
(..), FloatException
(..), FEnvState
, FEnv
,
42 -- * Controlled access to the floating point environment
43 -- | These functions can still break referential transparency, because it
44 -- is possible to arrange for a pure floating point expression to be forced
45 -- during the execution of 'fenvEval'. The easiest way to ensure that this
46 -- does not happen is to only use such expressions as the argument to
47 -- 'pure'; never as the argument to 'fmap'.
48 fenvEval
, withRoundingMode
, raiseExceptions
, holdExceptions
,
49 holdExceptions_
, fenvTrace
,
51 -- * Direct access to the floating point environment
52 -- | Special care must be taken when using these functions. Modifying the
53 -- floating point environment will affect all floating point computations
54 -- that have not yet been evaluated.
55 unsafeSaveEnvironment
, unsafeRestoreEnvironment
,
56 unsafeTestExceptions
, unsafeRaiseExceptions
,
57 unsafeSetRoundingMode
, getRoundingMode
62 import Prelude
hiding (Float, Double, Floating
(..), RealFloat
(..))
64 import Data
.Floating
.Types
65 import Control
.Exception
66 import Control
.Applicative
73 foreign import ccall unsafe
"set_roundmode"
74 set_roundmode
:: CInt
-> IO CInt
75 foreign import ccall unsafe
"get_roundmode"
76 get_roundmode
:: IO CInt
78 foreign import ccall unsafe
"fegetenv"
79 c_fegetenv
:: Ptr FEnvState
-> IO CInt
80 foreign import ccall unsafe
"fesetenv"
81 c_fesetenv
:: Ptr FEnvState
-> IO CInt
82 foreign import ccall unsafe
"feholdexcept"
83 c_feholdexcept
:: Ptr FEnvState
-> IO CInt
84 foreign import ccall unsafe
"fenv_test_excepts"
85 fenv_test_excepts
:: IO CUInt
86 foreign import ccall unsafe
"fenv_raise_excepts"
87 fenv_raise_excepts
:: CUInt
-> IO CInt
89 data RoundingMode
= ToNearest | Upward | Downward | TowardZero
90 deriving (Show, Read, Enum
, Bounded
)
91 data FloatException
= DivByZero | Inexact | Invalid | Overflow | Underflow
92 deriving (Show, Read, Enum
, Bounded
)
94 -- | Opaque type which stores the complete floating point environment. It
95 -- corresponds to the C type @fenv_t@.
96 newtype FEnvState
= FEnvState
(ForeignPtr FEnvState
)
98 instance Storable FEnvState
where
99 sizeOf
= const SIZEOF_FENV_T
100 alignment
= const ALIGNOF_FENV_T
103 fp
<- mallocForeignPtrBytes SIZEOF_FENV_T
104 withForeignPtr fp
(\p
-> copyBytes p ptr SIZEOF_FENV_T
)
105 return (FEnvState fp
)
106 poke ptr
(FEnvState fp
) = do
107 withForeignPtr fp
(\p
-> copyBytes ptr p SIZEOF_FENV_T
)
109 -- | Container for computations which will be run in a modified floating point
110 -- environment. The FEnv container records all operations for later evaluation
111 -- by 'fenvEval'. Note that 'pure' is strict in order to force evaluation
112 -- of floating point values stored in the container.
114 -- Do not use the 'Eq' or 'Show' instances, they are provided only because Num
116 data FEnv a
= forall b
. FEnv
(b
-> a
) !b
118 -- In the following instances, the two FEnv parts must be bashed together
119 -- exactly once every time the contained value is extracted. Care must be
120 -- taken to avoid memoization of this result. Interestingly, FEnv is not an
121 -- instance of Monad: While join (FEnv f x) = f x has the right type, it does
122 -- not satisfy this important property.
124 instance Functor FEnv
where
125 fmap f
(FEnv g x
) = FEnv
(f
. g
) x
127 instance Applicative FEnv
where
129 (FEnv f x
) <*> (FEnv g y
) = FEnv
(\(x
',y
') -> f x
' . g
$ y
') (x
, y
)
131 -- For hysterical raisins, we need to instance Eq and Show since they are
132 -- superclasses of Num.
133 instance Eq a
=> Eq
(FEnv a
) where
134 (==) = error "The Eq instance for FEnv is a lie."
135 instance Show a
=> Show (FEnv a
) where
136 show = const "<<FEnv>>"
138 instance Num a
=> Num
(FEnv a
) where
142 negate = liftA
negate
143 signum = liftA
signum
145 fromInteger = pure
. fromInteger
147 instance Fractional a
=> Fractional
(FEnv a
) where
150 fromRational = pure
. fromRational
152 instance Floating a
=> Floating
(FEnv a
) where
170 instance RealFloat a
=> RealFloat
(FEnv a
) where
172 copysign
= liftA2 copysign
173 nextafter
= liftA2 nextafter
187 lgamma
= liftA lgamma
188 nearbyint
= liftA nearbyint
191 infinity
= pure infinity
195 -- | Saves the current floating point environment and, optionally, clears all
196 -- floating point exception flags and sets non-stop (continue on exceptions)
198 unsafeSaveEnvironment
:: Bool -> IO FEnvState
199 unsafeSaveEnvironment reset
= alloca
$ \env
-> do
201 unless (rc
== 0) $ fail "Error saving floating point environment."
204 saveEnv
= if reset
then c_feholdexcept
else c_fegetenv
206 -- | Restores a previously-saved floating point environment and returns the
207 -- list of floating point exceptions that occurred prior to restoring the
209 unsafeRestoreEnvironment
:: FEnvState
-> IO [FloatException
]
210 unsafeRestoreEnvironment
(FEnvState fp
) = do
211 excepts
<- unsafeTestExceptions
212 rc
<- withForeignPtr fp c_fesetenv
213 unless (rc
== 0) $ fail "Error restoring floating point environment."
216 -- | Return the currently raised floating point exceptions as a list.
217 unsafeTestExceptions
:: IO [FloatException
]
218 unsafeTestExceptions
= do
219 rawExcepts
<- fenv_test_excepts
220 return $! filter (testBit rawExcepts
. fromEnum) [minBound..maxBound]
222 -- | Raises the given floating point exceptions.
223 unsafeRaiseExceptions
:: [FloatException
] -> IO ()
224 unsafeRaiseExceptions ex
= do
225 rc
<- fenv_raise_excepts
$ foldr (flip setBit
. fromEnum) 0 ex
226 unless (rc
== 0) $ fail "Error raising floating point exceptions."
228 unsafeSetRoundingMode
:: RoundingMode
-> IO ()
229 unsafeSetRoundingMode mode
= do
230 rc
<- set_roundmode
(fromIntegral (fromEnum mode
))
231 unless (rc
== 0) $ fail "Error setting rounding mode"
233 getRoundingMode
:: IO RoundingMode
236 unless (rc
>= 0) $ fail "Error getting rounding mode"
237 return . toEnum . fromIntegral $ rc
239 -- | Evaluate an FEnv using a specific rounding mode. Rounding mode selections
240 -- nest: subcomputations might use another mode. The default rounding mode is
242 withRoundingMode
:: RoundingMode
-> FEnv a
-> FEnv a
243 withRoundingMode mode
(FEnv f x
) = FEnv unsafePerformIO
$ do
244 oldMode
<- getRoundingMode
245 unsafeSetRoundingMode mode
247 unsafeSetRoundingMode oldMode
250 -- | Raise floating point exceptions as part of an FEnv computation.
251 raiseExceptions
:: [FloatException
] -> FEnv a
-> FEnv a
252 raiseExceptions ex
= liftA2
seq $
253 FEnv unsafePerformIO
(unsafeRaiseExceptions ex
)
255 -- | Save and restore the floating point state across an FEnv computation.
256 -- The result includes the exceptions returned during this computation.
257 holdExceptions
:: FEnv a
-> FEnv
(a
, [FloatException
])
258 holdExceptions
= FEnv unsafePerformIO
. fenvEval
260 -- | Same as 'holdExceptions', except that any exceptions raised during the
261 -- computation are discarded.
262 holdExceptions_
:: FEnv a
-> FEnv a
263 holdExceptions_
= fmap fst . holdExceptions
265 -- | This function is to help with debugging the floating point environment
266 -- handling. @fenvTrace msg x@ constructs an FEnv value containing @x@ that
267 -- prints @msg@ (using 'Debug.Trace.trace') whenever the value is extracted.
268 fenvTrace
:: String -> a
-> FEnv a
269 fenvTrace s
= fmap (trace s
) . pure
271 -- | Runs all the computations which are recorded in an FEnv container. The
272 -- floating point environment is preserved across this call, and any floating
273 -- point exceptions which were raised during the computation are returned.
274 fenvEval
:: FEnv a
-> IO (a
, [FloatException
])
275 fenvEval
(FEnv f x
) = do
276 env
<- unsafeSaveEnvironment
True
278 ex
<- unsafeRestoreEnvironment env