7aea8e655bebf49f42aec95ea88147363006120b
[altfloat.git] / Data / Floating / Environment.hs
blob7aea8e655bebf49f42aec95ea88147363006120b
1 {-
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.
7 -}
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
12 -- function
14 -- @ (+) :: Double -> Double -> Double@
16 -- potentially both depends on and modifies the global floating point
17 -- environment.
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,
39 -- * Data types
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, fenvTrace,
50 -- * Direct access to the floating point environment
51 -- | Special care must be taken when using these functions. Modifying the
52 -- floating point environment will affect all floating point computations
53 -- that have not yet been evaluated.
54 unsafeSaveEnvironment, unsafeRestoreEnvironment,
55 unsafeRaiseExceptions,
56 unsafeSetRoundingMode, getRoundingMode
57 ) where
59 #include <config.h>
61 import Prelude hiding (Float, Double, Floating(..), RealFloat(..))
63 import Data.Floating.Classes
64 import Control.Exception
65 import Control.Applicative
66 import Control.Monad
68 import System.IO.Unsafe
69 import Debug.Trace
71 import Foreign.C
72 import Foreign
74 foreign import ccall unsafe "set_roundmode"
75 set_roundmode :: CInt -> IO CInt
76 foreign import ccall unsafe "get_roundmode"
77 get_roundmode :: IO CInt
79 foreign import ccall unsafe "fegetenv"
80 c_fegetenv :: Ptr FEnvState -> IO CInt
81 foreign import ccall unsafe "feholdexcept"
82 c_feholdexcept :: Ptr FEnvState -> IO CInt
83 foreign import ccall unsafe "fenv_restore"
84 fenv_restore :: Ptr FEnvState -> Ptr CUInt -> IO CInt
85 foreign import ccall unsafe "fenv_raise_excepts"
86 fenv_raise_excepts :: CUInt -> IO CInt
88 data RoundingMode = ToNearest | Upward | Downward | TowardZero
89 deriving (Show, Read, Enum, Bounded)
90 data FloatException = DivByZero | Inexact | Invalid | Overflow | Underflow
91 deriving (Show, Read, Enum, Bounded)
93 -- | Opaque type which stores the complete floating point environment. It
94 -- corresponds to the C type @fenv_t@.
95 newtype FEnvState = FEnvState (ForeignPtr FEnvState)
97 instance Storable FEnvState where
98 sizeOf = const SIZEOF_FENV_T
99 alignment = const ALIGNOF_FENV_T
101 peek ptr = do
102 fp <- mallocForeignPtrBytes SIZEOF_FENV_T
103 withForeignPtr fp (\p -> copyBytes p ptr SIZEOF_FENV_T)
104 return (FEnvState fp)
105 poke ptr (FEnvState fp) = do
106 withForeignPtr fp (\p -> copyBytes ptr p SIZEOF_FENV_T)
108 -- | Container for computations which will be run in a modified floating point
109 -- environment. The FEnv container records all operations for later evaluation
110 -- by 'fenvEval'. Note that 'pure' is strict in order to force evaluation
111 -- of floating point values stored in the container.
113 -- Do not use the 'Eq' or 'Show' instances, they are provided only because Num
114 -- requires them.
115 data FEnv a = forall b . FEnv (b -> a) !b
117 -- In the following instances, the two FEnv parts must be bashed together
118 -- exactly once every time the contained value is extracted. Care must be
119 -- taken to avoid memoization of this result. Interestingly, FEnv is not an
120 -- instance of Monad: While join (FEnv f x) = f x has the right type, it does
121 -- not satisfy this important property.
123 instance Functor FEnv where
124 fmap f (FEnv g x) = FEnv (f . g) x
126 instance Applicative FEnv where
127 pure = FEnv id
128 (FEnv f x) <*> (FEnv g y) = FEnv (\(x',y') -> f x' . g $ y') (x, y)
130 -- For hysterical raisins, we need to instance Eq and Show since they are
131 -- superclasses of Num.
132 instance Eq a => Eq (FEnv a) where
133 (==) = error "The Eq instance for FEnv is a lie."
134 instance Show a => Show (FEnv a) where
135 show = const "<<FEnv>>"
137 instance Num a => Num (FEnv a) where
138 (+) = liftA2 (+)
139 (-) = liftA2 (-)
140 (*) = liftA2 (*)
141 negate = liftA negate
142 signum = liftA signum
143 abs = liftA abs
144 fromInteger = pure . fromInteger
146 instance Fractional a => Fractional (FEnv a) where
147 (/) = liftA2 (/)
148 recip = liftA recip
149 fromRational = pure . fromRational
151 instance Floating a => Floating (FEnv a) where
152 (**) = liftA2 (**)
153 sqrt = liftA sqrt
154 acos = liftA acos
155 asin = liftA asin
156 atan = liftA atan
157 cos = liftA cos
158 sin = liftA sin
159 tan = liftA tan
160 cosh = liftA cosh
161 sinh = liftA sinh
162 tanh = liftA tanh
163 exp = liftA exp
164 log = liftA log
165 acosh = liftA acosh
166 asinh = liftA asinh
167 atanh = liftA atanh
169 instance RealFloat a => RealFloat (FEnv a) where
170 fma = liftA3 fma
171 copysign = liftA2 copysign
172 nextafter = liftA2 nextafter
173 fmod = liftA2 fmod
174 frem = liftA2 frem
175 atan2 = liftA2 atan2
176 hypot = liftA2 hypot
177 cbrt = liftA cbrt
178 exp2 = liftA exp2
179 expm1 = liftA expm1
180 log10 = liftA log10
181 log1p = liftA log1p
182 log2 = liftA log2
183 erf = liftA erf
184 erfc = liftA erfc
185 gamma = liftA gamma
186 lgamma = liftA lgamma
187 nearbyint = liftA nearbyint
188 rint = liftA rint
190 infinity = pure infinity
191 nan = pure nan
192 pi = pure pi
194 -- | Saves the current floating point environment and, optionally, clears all
195 -- floating point exception flags and sets non-stop (continue on exceptions)
196 -- mode.
197 unsafeSaveEnvironment :: Bool -> IO FEnvState
198 unsafeSaveEnvironment reset = alloca $ \env -> do
199 rc <- saveEnv env
200 unless (rc == 0) $ fail "Error saving floating point environment."
201 peek env
202 where
203 saveEnv = if reset then c_feholdexcept else c_fegetenv
205 -- | Restores a previously-saved floating point environment and returns the
206 -- list of floating point exceptions that occurred prior to restoring the
207 -- environment.
208 unsafeRestoreEnvironment :: FEnvState -> IO [FloatException]
209 unsafeRestoreEnvironment (FEnvState fp) = alloca $ \pe -> do
210 rc <- withForeignPtr fp (flip fenv_restore pe)
211 unless (rc == 0) $ fail "Error restoring floating point environment."
212 rawExcepts <- peek pe
213 return $! filter (testBit rawExcepts . fromEnum) [minBound..maxBound]
215 -- | Raises the given floating point exceptions.
216 unsafeRaiseExceptions :: [FloatException] -> IO ()
217 unsafeRaiseExceptions ex = do
218 rc <- fenv_raise_excepts $ foldr (flip setBit . fromEnum) 0 ex
219 unless (rc == 0) $ fail "Error raising floating point exceptions."
221 unsafeSetRoundingMode :: RoundingMode -> IO ()
222 unsafeSetRoundingMode mode = do
223 rc <- set_roundmode (fromIntegral (fromEnum mode))
224 unless (rc == 0) $ fail "Error setting rounding mode"
226 getRoundingMode :: IO RoundingMode
227 getRoundingMode = do
228 rc <- get_roundmode
229 unless (rc >= 0) $ fail "Error getting rounding mode"
230 return . toEnum . fromIntegral $ rc
232 -- | Evaluate an FEnv using a specific rounding mode. Rounding mode selections
233 -- nest: subcomputations might use another mode. The default rounding mode is
234 -- unspecified.
235 withRoundingMode :: RoundingMode -> FEnv a -> FEnv a
236 withRoundingMode mode (FEnv f x) = FEnv unsafePerformIO $ do
237 oldMode <- getRoundingMode
238 unsafeSetRoundingMode mode
239 rc <- evaluate $ f x
240 unsafeSetRoundingMode oldMode
241 return rc
243 -- | Raise floating point exceptions as part of an FEnv computation.
244 raiseExceptions :: [FloatException] -> FEnv a -> FEnv a
245 raiseExceptions ex = liftA2 seq $
246 FEnv unsafePerformIO (unsafeRaiseExceptions ex)
248 -- | This function is to help with debugging the floating point environment
249 -- handling. @fenvTrace msg x@ constructs an FEnv value containing @x@ that
250 -- prints @msg@ (using 'Debug.Trace.trace') whenever the value is extracted.
251 fenvTrace :: String -> a -> FEnv a
252 fenvTrace s = fmap (trace s) . pure
254 -- | Runs all the computations which are recorded in an FEnv container. The
255 -- floating point environment is preserved across this call, and any floating
256 -- point exceptions which were raised during the computation are returned.
257 fenvEval :: FEnv a -> IO (a, [FloatException])
258 fenvEval (FEnv f x) = do
259 env <- unsafeSaveEnvironment True
260 rc <- evaluate $ f x
261 ex <- unsafeRestoreEnvironment env
262 return (rc, ex)