Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/8a3399d5169af7a82c2c13ca7184fd307f6ea3d8 >--------------------------------------------------------------- commit 8a3399d5169af7a82c2c13ca7184fd307f6ea3d8 Author: Ian Lynagh <i...@well-typed.com> Date: Wed Jan 16 16:35:44 2013 +0000 Use the RTS getMonotonicTime to implement getMonotonicNSec; fixes #7299 I'm not entirely sure where the segfault was coming from, but it was almost certainly related to there being 2 copies of the base package around, and the interpreted one not having its timer code initialised. >--------------------------------------------------------------- GHC/Event/Clock.hsc | 105 +++----------------------------------------------- GHC/Event/Thread.hs | 2 - 2 files changed, 7 insertions(+), 100 deletions(-) diff --git a/GHC/Event/Clock.hsc b/GHC/Event/Clock.hsc index e3c1218..37e26cd 100644 --- a/GHC/Event/Clock.hsc +++ b/GHC/Event/Clock.hsc @@ -1,108 +1,17 @@ {-# 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 diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs index 35557a4..d7ebd59 100644 --- a/GHC/Event/Thread.hs +++ b/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 () _______________________________________________ ghc-commits mailing list ghc-commits@haskell.org http://www.haskell.org/mailman/listinfo/ghc-commits
