Merge branch 'master' of http://darcs.haskell.org//packages/base

libraries/base/GHC/Event/Clock.hsc

 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-}
+{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-}
 
-module GHC.Event.Clock (getMonotonicTime, initializeTimer) where
+module GHC.Event.Clock (getMonotonicTime) where
 
-#include "HsBase.h"
-
-import Foreign
-import Foreign.C.Types
 import GHC.Base
 import GHC.Real
-
-#if !darwin_HOST_OS
-import Foreign.C.Error (throwErrnoIfMinus1_)
-import GHC.Err
-import GHC.Num
-#endif
-
--- TODO: Implement this for Windows.
-
-initializeTimer :: IO ()
+import Data.Word
 
 -- | Return monotonic time in seconds, since some unspecified starting point
 getMonotonicTime :: IO Double
+getMonotonicTime = do w <- getMonotonicNSec
+                      return (fromIntegral w / 1000000000)
 
-------------------------------------------------------------------------
--- FFI binding
-
-#if HAVE_CLOCK_GETTIME
-
-initializeTimer = return ()
-
-getMonotonicTime = do
-    tv <- with (CTimespec 0 0) $ \tvptr -> do
-        throwErrnoIfMinus1_ "clock_gettime" (clock_gettime (#const CLOCK_ID) tvptr)
-        peek tvptr
-    let !t = realToFrac (sec tv) + realToFrac (nsec tv) / 1000000000.0
-    return t
-
-data CTimespec = CTimespec
-    { sec  :: {-# UNPACK #-} !CTime
-    , nsec :: {-# UNPACK #-} !CLong
-    }
-
-instance Storable CTimespec where
-    sizeOf _ = #size struct timespec
-    alignment _ = alignment (undefined :: CLong)
-
-    peek ptr = do
-        sec' <- #{peek struct timespec, tv_sec} ptr
-        nsec' <- #{peek struct timespec, tv_nsec} ptr
-        return $ CTimespec sec' nsec'
-
-    poke ptr tv = do
-        #{poke struct timespec, tv_sec} ptr (sec tv)
-        #{poke struct timespec, tv_nsec} ptr (nsec tv)
-
-foreign import capi unsafe "HsBase.h clock_gettime" clock_gettime
-    :: Int -> Ptr CTimespec -> IO CInt
-
-#elif darwin_HOST_OS
-
-getMonotonicTime = do
-    with 0.0 $ \timeptr -> do
-    absolute_time timeptr
-    ctime <- peek timeptr
-    let !time = realToFrac ctime
-    return time
-
-foreign import capi unsafe "HsBase.h absolute_time" absolute_time ::
-    Ptr CDouble -> IO ()
-
-foreign import capi unsafe "HsBase.h initialize_timer"
-  initializeTimer :: IO ()
-
-#else
-
-initializeTimer = return ()
-
-getMonotonicTime = do
-    tv <- with (CTimeval 0 0) $ \tvptr -> do
-        throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)
-        peek tvptr
-    let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0
-    return t
-
-data CTimeval = CTimeval
-    { sec  :: {-# UNPACK #-} !CTime
-    , usec :: {-# UNPACK #-} !CSUSeconds
-    }
-
-instance Storable CTimeval where
-    sizeOf _ = #size struct timeval
-    alignment _ = alignment (undefined :: CLong)
-
-    peek ptr = do
-        sec' <- #{peek struct timeval, tv_sec} ptr
-        usec' <- #{peek struct timeval, tv_usec} ptr
-        return $ CTimeval sec' usec'
-
-    poke ptr tv = do
-        #{poke struct timeval, tv_sec} ptr (sec tv)
-        #{poke struct timeval, tv_usec} ptr (usec tv)
-
-foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday
-    :: Ptr CTimeval -> Ptr () -> IO CInt
+foreign import ccall unsafe "getMonotonicNSec"
+    getMonotonicNSec :: IO Word64
 
-#endif

libraries/base/GHC/Event/Thread.hs

@@ -27,7 +27,6 @@ import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
 import GHC.Event.Internal (eventIs, evtClose)
 import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                              new, registerFd, unregisterFd_, registerTimeout)
-import GHC.Event.Clock (initializeTimer)
 import qualified GHC.Event.Manager as M
 import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.Types (Fd)
@@ -167,7 +166,6 @@ ensureIOManagerIsRunning :: IO ()
 ensureIOManagerIsRunning
   | not threaded = return ()
   | otherwise = do
-      initializeTimer
       startIOManagerThread
 
 startIOManagerThread :: IO ()

libraries/base/GHC/Generics.hs

@@ -63,38 +63,38 @@ data V1 p
 
 -- | Unit: used for constructors without arguments
 data U1 p = U1
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Used for marking occurrences of the parameter
 newtype Par1 p = Par1 { unPar1 :: p }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Recursive calls of kind * -> *
 newtype Rec1 f p = Rec1 { unRec1 :: f p }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Constants, additional parameters and recursion of kind *
 newtype K1 i c p = K1 { unK1 :: c }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Meta-information (constructor names, etc.)
 newtype M1 i c f p = M1 { unM1 :: f p }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Sums: encode choice between constructors
 infixr 5 :+:
 data (:+:) f g p = L1 (f p) | R1 (g p)
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Products: encode multiple arguments to constructors
 infixr 6 :*:
 data (:*:) f g p = f p :*: g p
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Composition of functors
 infixr 7 :.:
 newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Read, Show, Generic)
 
 -- | Tag for K1: recursion (of kind *)
 data R
@@ -159,12 +159,12 @@ class Constructor c where
 
 -- | Datatype to represent the arity of a tuple.
 data Arity = NoArity | Arity Int
-  deriving (Eq, Show, Ord, Read)
+  deriving (Eq, Show, Ord, Read, Generic)
 
 -- | Datatype to represent the fixity of a constructor. An infix
 -- | declaration directly corresponds to an application of 'Infix'.
 data Fixity = Prefix | Infix Associativity Int
-  deriving (Eq, Show, Ord, Read)
+  deriving (Eq, Show, Ord, Read, Generic)
 
 -- | Get the precedence of a fixity value.
 prec :: Fixity -> Int
@@ -175,7 +175,7 @@ prec (Infix _ n) = n
 data Associativity = LeftAssociative
                    | RightAssociative
                    | NotAssociative
-  deriving (Eq, Show, Ord, Read)
+  deriving (Eq, Show, Ord, Read, Generic)
 
 -- | Representable types of kind *.
 -- This class is derivable in GHC with the DeriveGeneric flag on.

libraries/base/System/CPUTime.hsc

@@ -39,14 +39,6 @@ import CPUTime ( getCPUTime, cpuTimePrecision )
 #ifdef __GLASGOW_HASKELL__
 import Foreign.Safe
 import Foreign.C
-#if !defined(CLK_TCK)
-import System.IO.Unsafe (unsafePerformIO)
-#endif
-
--- For _SC_CLK_TCK
-#if HAVE_UNISTD_H
-#include <unistd.h>
-#endif
 
 -- For struct rusage
 #if !defined(mingw32_HOST_OS) && !defined(irix_HOST_OS)
@@ -60,11 +52,6 @@ import System.IO.Unsafe (unsafePerformIO)
 #include <windows.h>
 #endif
 
--- for CLK_TCK
-#if HAVE_TIME_H
-#include <time.h>
-#endif
-
 -- for struct tms
 #if HAVE_SYS_TIMES_H
 #include <sys/times.h>
@@ -185,13 +172,8 @@ cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
 #endif
 
 #ifdef __GLASGOW_HASKELL__
+foreign import ccall unsafe clk_tck :: CLong
+
 clockTicks :: Int
-clockTicks =
-#if defined(CLK_TCK)
-    (#const CLK_TCK)
-#else
-    unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)
-foreign import ccall unsafe sysconf :: CInt -> IO CLong
-#endif
+clockTicks = fromIntegral clk_tck
 #endif /* __GLASGOW_HASKELL__ */
-

libraries/base/aclocal.m4

@@ -126,49 +126,47 @@ AC_DEFUN([FPTOOLS_CHECK_HTYPE_ELSE],[
     AC_CACHE_VAL(AC_CV_NAME,[
         AC_CV_NAME_supported=yes
         FP_COMPUTE_INT([HTYPE_IS_INTEGRAL],
-                       [(($1)((int)(($1)1.4))) == (($1)1.4)],
-                       [FPTOOLS_HTYPE_INCLUDES],[AC_CV_NAME_supported=no])
-        if test "$AC_CV_NAME_supported" = "yes"
+                       [($1)1.4],
+                       [FPTOOLS_HTYPE_INCLUDES],[HTYPE_IS_INTEGRAL=0])
+
+        if test "$HTYPE_IS_INTEGRAL" -eq 0
         then
-            if test "$HTYPE_IS_INTEGRAL" -eq 0
+            FP_COMPUTE_INT([HTYPE_IS_FLOAT],[sizeof($1) == sizeof(float)],
+                           [FPTOOLS_HTYPE_INCLUDES],
+                           [AC_CV_NAME_supported=no])
+            FP_COMPUTE_INT([HTYPE_IS_DOUBLE],[sizeof($1) == sizeof(double)],
+                           [FPTOOLS_HTYPE_INCLUDES],
+                           [AC_CV_NAME_supported=no])
+            FP_COMPUTE_INT([HTYPE_IS_LDOUBLE],[sizeof($1) == sizeof(long double)],
+                           [FPTOOLS_HTYPE_INCLUDES],
+                           [AC_CV_NAME_supported=no])
+            if test "$HTYPE_IS_FLOAT" -eq 1
+            then
+                AC_CV_NAME=Float
+            elif test "$HTYPE_IS_DOUBLE" -eq 1
             then
-                FP_COMPUTE_INT([HTYPE_IS_FLOAT],[sizeof($1) == sizeof(float)],
-                               [FPTOOLS_HTYPE_INCLUDES],
-                               [AC_CV_NAME_supported=no])
-                FP_COMPUTE_INT([HTYPE_IS_DOUBLE],[sizeof($1) == sizeof(double)],
-                               [FPTOOLS_HTYPE_INCLUDES],
-                               [AC_CV_NAME_supported=no])
-                FP_COMPUTE_INT([HTYPE_IS_LDOUBLE],[sizeof($1) == sizeof(long double)],
-                               [FPTOOLS_HTYPE_INCLUDES],
-                               [AC_CV_NAME_supported=no])
-                if test "$HTYPE_IS_FLOAT" -eq 1
-                then
-                    AC_CV_NAME=Float
-                elif test "$HTYPE_IS_DOUBLE" -eq 1
-                then
-                    AC_CV_NAME=Double
-                elif test "$HTYPE_IS_LDOUBLE" -eq 1
-                then
-                    AC_CV_NAME=LDouble
-                else
-                    AC_CV_NAME_supported=no
-                fi
+                AC_CV_NAME=Double
+            elif test "$HTYPE_IS_LDOUBLE" -eq 1
+            then
+                AC_CV_NAME=LDouble
             else
-                FP_COMPUTE_INT([HTYPE_IS_SIGNED],[(($1)(-1)) < (($1)0)],
-                               [FPTOOLS_HTYPE_INCLUDES],
-                               [AC_CV_NAME_supported=no])
-                FP_COMPUTE_INT([HTYPE_SIZE],[sizeof($1) * 8],
-                               [FPTOOLS_HTYPE_INCLUDES],
-                               [AC_CV_NAME_supported=no])
-                if test "$HTYPE_IS_SIGNED" -eq 0
-                then
-                    AC_CV_NAME="Word$HTYPE_SIZE"
-                else
-                    AC_CV_NAME="Int$HTYPE_SIZE"
-                fi
+                AC_CV_NAME_supported=no
+            fi
+        else
+            FP_COMPUTE_INT([HTYPE_IS_SIGNED],[(($1)(-1)) < (($1)0)],
+                           [FPTOOLS_HTYPE_INCLUDES],
+                           [AC_CV_NAME_supported=no])
+            FP_COMPUTE_INT([HTYPE_SIZE],[sizeof($1) * 8],
+                           [FPTOOLS_HTYPE_INCLUDES],
+                           [AC_CV_NAME_supported=no])
+            if test "$HTYPE_IS_SIGNED" -eq 0
+            then
+                AC_CV_NAME="Word$HTYPE_SIZE"
+            else
+                AC_CV_NAME="Int$HTYPE_SIZE"
             fi
         fi
-        ])
+    ])
     if test "$AC_CV_NAME_supported" = no
     then
         $2

libraries/base/base.cabal

@@ -225,6 +225,7 @@ Library {
         cbits/inputReady.c
         cbits/primFloat.c
         cbits/md5.c
+        cbits/sysconf.c
     include-dirs: include
     includes:    HsBase.h
     install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h

libraries/base/cbits/sysconf.c

+#include "HsBaseConfig.h"
+
+/* For _SC_CLK_TCK */
+#if HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/* for CLK_TCK */
+#if HAVE_TIME_H
+#include <time.h>
+#endif
+
+long clk_tck(void) {
+#if defined(CLK_TCK)
+    return (CLK_TCK);
+#else
+    return sysconf(_SC_CLK_TCK);
+#endif
+}

libraries/base/tests/Numeric/all.T

@@ -15,4 +15,7 @@ test('num009', [ skip_if_fast
                # We also get another set of results for 1e02 with GHCi, so
                # I'm skipping that way altogether.
              compile_and_run, [''])
-test('num010', normal, compile_and_run, [''])
+test('num010',
+     if_platform('i386-apple-darwin', expect_broken_for(7043, 'ghci')),
+     compile_and_run,
+     [''])