From 014ecaf1223299544ae947a3789510c0d9561234 Mon Sep 17 00:00:00 2001 From: Nick Bowler Date: Wed, 18 Nov 2009 21:58:05 -0500 Subject: [PATCH] Initial commit --- .gitignore | 3 ++ Data/Floating.hs | 7 +++++ Data/Floating/Classes.hs | 11 ++++++++ Data/Floating/Double.hs | 69 +++++++++++++++++++++++++++++++++++++++++++++ Data/Floating/Prelude.hs | 8 ++++++ Data/Floating/Types.hs | 73 ++++++++++++++++++++++++++++++++++++++++++++++++ Setup.lhs | 4 +++ altfloat.cabal | 18 ++++++++++++ cfloat.c | 30 ++++++++++++++++++++ cfloat.h | 7 +++++ 10 files changed, 230 insertions(+) create mode 100644 .gitignore create mode 100644 Data/Floating.hs create mode 100644 Data/Floating/Classes.hs create mode 100644 Data/Floating/Double.hs create mode 100644 Data/Floating/Prelude.hs create mode 100644 Data/Floating/Types.hs create mode 100755 Setup.lhs create mode 100644 altfloat.cabal create mode 100644 cfloat.c create mode 100644 cfloat.h diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c17082e --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.o +*.hi +dist diff --git a/Data/Floating.hs b/Data/Floating.hs new file mode 100644 index 0000000..51c4b34 --- /dev/null +++ b/Data/Floating.hs @@ -0,0 +1,7 @@ +module Data.Floating ( + module Data.Floating.Classes, + module Data.Floating.Double, +) where + +import Data.Floating.Classes +import Data.Floating.Double diff --git a/Data/Floating/Classes.hs b/Data/Floating/Classes.hs new file mode 100644 index 0000000..91917d5 --- /dev/null +++ b/Data/Floating/Classes.hs @@ -0,0 +1,11 @@ +module Data.Floating.Classes where + +import Prelude hiding (Floating) + +class Fractional a => Floating a where + copysign :: a -> a -> a + infinity :: a + nan :: a + + infinity = 1/0 + nan = 0/0 diff --git a/Data/Floating/Double.hs b/Data/Floating/Double.hs new file mode 100644 index 0000000..36eddc9 --- /dev/null +++ b/Data/Floating/Double.hs @@ -0,0 +1,69 @@ +{-# INCLUDE stdlib.h math.h cfloat.h #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +module Data.Floating.Double ( + Double +) where + +import Prelude hiding (Double, Floating) +import Control.Applicative +import Control.Monad +import Data.Ratio + +import GHC.Integer +import GHC.Prim + +import Foreign +import Foreign.C +import System.IO.Unsafe + +import Data.Floating.Types +import Data.Floating.Classes + +foreign import ccall unsafe "double_to_string" + double_to_string :: CString -> CDouble -> IO CInt +foreign import ccall unsafe "double_signum" + double_signum :: CDouble -> CDouble +foreign import ccall unsafe "fabs" + c_abs :: CDouble -> CDouble +foreign import ccall unsafe "strtod" + c_strtod :: CString -> Ptr CString -> IO CDouble +foreign import ccall unsafe "copysign" + c_copysign :: CDouble -> CDouble -> CDouble + +instance Show Double where + show x = unsafePerformIO $ do + size <- double_to_string nullPtr (toFloating x) + allocaArray0 (fromIntegral size) $ \buf -> do + double_to_string buf (toFloating x) + peekCString buf + +instance Read Double where + readsPrec _ s = unsafePerformIO . withCString s $ \str -> do + alloca $ \endbuf -> do + val <- toFloating <$> c_strtod str endbuf + end <- peek endbuf + if end == str + then return [] + else peekCString end >>= \rem -> return [(val, rem)] + +instance Eq Double where + (D# x) == (D# y) = x ==## y + (D# x) /= (D# y) = x /=## y + +instance Num Double where + (D# x) + (D# y) = D# (x +## y) + (D# x) - (D# y) = D# (x -## y) + (D# x) * (D# y) = D# (x *## y) + negate (D# x) = D# (negateDouble# x) + signum = toFloating . double_signum . toFloating + abs = toFloating . c_abs . toFloating + fromInteger x = D# (doubleFromInteger x) + +instance Fractional Double where + (D# x) / (D# y) = D# (x /## y) + fromRational = liftM2 (/) + (fromInteger . numerator) + (fromInteger . denominator) + +instance Floating Double where + copysign x y = toFloating $ c_copysign (toFloating x) (toFloating y) diff --git a/Data/Floating/Prelude.hs b/Data/Floating/Prelude.hs new file mode 100644 index 0000000..fa1c48c --- /dev/null +++ b/Data/Floating/Prelude.hs @@ -0,0 +1,8 @@ +{- | Alternate prelude that replaces the floating point types with our own. -} +module Data.Floating.Prelude ( + module Data.Floating, + module Prelude +) where + +import Prelude hiding (Floating, Double, Float) +import Data.Floating diff --git a/Data/Floating/Types.hs b/Data/Floating/Types.hs new file mode 100644 index 0000000..5826ab0 --- /dev/null +++ b/Data/Floating/Types.hs @@ -0,0 +1,73 @@ +-- | This module provides an alternate definition of the floating point types +-- in Haskell. +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +{-# INCLUDE cfloat.h #-} +module Data.Floating.Types ( + Float(..), Double(..), FloatConvert(..) +) where + +import Prelude hiding (Double, Float) +import qualified GHC.Exts as GHC +import GHC.Integer +import GHC.Prim +import Foreign.C + +import Unsafe.Coerce + +-- | For reasons unknown to me, we actually need to do foreign calls in order +-- to convert between floating types. +foreign import ccall unsafe "double_to_float" + double_to_float :: CDouble -> CFloat +-- | The opposite of double_to_float. +foreign import ccall unsafe "float_to_double" + float_to_double :: CFloat -> CDouble + +-- | The Double type. This is expected to be an identical declaration to +-- the one found in GHC.Prim. We avoid simply using GHC's type because we need +-- to define our own class instances. +data Double = D# Double# + +-- | The Float type. +data Float = F# Float# + +-- | This type is identical to CDouble. For some reason unknown to me, it is +-- impossible to marshal data from Double to CDouble without losing +-- information. The issue is further complicated by Foreign.C.Types not +-- exporting CDouble's constructor. Thus, to marshal data from Double to +-- CDouble, we construct an instance of this type and then use unsafeCoerce. +newtype FuckFFIDouble = FuckD Double + +-- | The analogue of FuckFFIDouble for CFloat. +newtype FuckFFIFloat = FuckF Float + +-- | Coercion to floating point types. +class FloatConvert a b where + toFloating :: a -> b + +instance FloatConvert Double CDouble where + toFloating = unsafeCoerce . FuckD + +instance FloatConvert CDouble Double where + toFloating f = let FuckD x = unsafeCoerce f in x + +instance FloatConvert Float CFloat where + toFloating = unsafeCoerce . FuckF + +instance FloatConvert CFloat Float where + toFloating f = let FuckF x = unsafeCoerce f in x + +instance FloatConvert Double Float where + toFloating = toFloating . double_to_float . toFloating + +instance FloatConvert Float Double where + toFloating = toFloating . float_to_double . toFloating + +instance Integral a => FloatConvert a Double where + toFloating x = D# (doubleFromInteger (toInteger x)) + +instance Integral a => FloatConvert a Float where + toFloating x = F# (floatFromInteger (toInteger x)) + +instance FloatConvert a a where + toFloating = id diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 0000000..3eb981e --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/altfloat.cabal b/altfloat.cabal new file mode 100644 index 0000000..a7af27d --- /dev/null +++ b/altfloat.cabal @@ -0,0 +1,18 @@ +Name: AltFloat +Version: 0.1 +Cabal-Version: >= 1.2 +Author: Nick Bowler +Category: Numerical +Synopsis: Alternative floating point support for GHC. +Build-Type: Simple + +Library + Build-Depends: base, ghc-prim, integer + C-Sources: cfloat.c + Ghc-Options: -O2 + Exposed-Modules: + Data.Floating.Classes, + Data.Floating.Types, + Data.Floating.Double, + Data.Floating.Prelude, + Data.Floating diff --git a/cfloat.c b/cfloat.c new file mode 100644 index 0000000..f79eddc --- /dev/null +++ b/cfloat.c @@ -0,0 +1,30 @@ +#include +#include +#include +#include + +#include "cfloat.h" + +int double_to_string(char *buf, double val) +{ + if (buf == NULL) + return snprintf(NULL, 0, "%a", val); + return sprintf(buf, "%a", val); +} + +double double_signum(double val) +{ + if (signbit(val)) + return -1; + return 1; +} + +float double_to_float(double val) +{ + return val; +} + +double float_to_double(float val) +{ + return val; +} diff --git a/cfloat.h b/cfloat.h new file mode 100644 index 0000000..70ac1cf --- /dev/null +++ b/cfloat.h @@ -0,0 +1,7 @@ +#ifndef MARSHAL_H_ +#define MARSHAL_H_ + +int fmt_double(char *buf, double val); +double double_sign(double val); + +#endif -- 2.11.4.GIT