Commit f9d70457 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 71221e24 94e6d7db
{-# 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
......@@ -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 ()
......
......@@ -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.
......
......@@ -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__ */
......@@ -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
......
......@@ -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
......
#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
}
......@@ -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,
[''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment